[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『このVBAをもっと軽くできますか？？』（やす）
Sub 転記用09月()
Dim MyRNG As Range
Dim myData As Variant
Dim myUnion As Range
Dim n
Dim k
Dim I As Long
If vbYes = MsgBox("実行すると戻せません。実行しますか？", vbYesNo) Then
MsgBox "実行しました｡"
Else
MsgBox "中止しました。"
Exit Sub
End If
n = Cells(Rows.Count, "B").End(xlUp).Row
For k = 6 To n
Cells(k, "AB") = Cells(k, "R")
Cells(k, "AC") = Cells(k, "S")
Cells(k, "AD") = Cells(k, "T")
Cells(k, "AE") = Cells(k, "U")
Cells(k, "AF") = Cells(k, "V")
Cells(k, "AG") = Cells(k, "W")
Cells(k, "AH") = Cells(k, "X")
Cells(k, "AI") = Cells(k, "Y")
Next k
Set MyRNG = Range("B6:AI10000") '表の範囲
myData = Range("V6:W10000").Value '比べる列
For I = LBound(myData) To UBound(myData)
If myData(I, 1) <> myData(I, 2) Then
If myUnion Is Nothing Then '見つかったとき
Set myUnion = MyRNG.Rows(I)
Else
Set myUnion = Union(myUnion, MyRNG.Rows(I))
End If
End If
Next I
If Not myUnion Is Nothing Then
myUnion.Copy Worksheets("R3.10").Range("B6") 'コピー先
End If
End Sub
当月シートから翌月シートに対して、受注残と出荷の差が0以外の物件をコピーするVBAです。
V列が受注残でW列が今月の出荷数なのでV-W＝0で物件終了としています。
処理が少し重いのでもっと簡単なコードがあれば宜しくお願いします。
＜ 使用 Excel：Excel2016、使用 OS：unknown ＞
（砂糖） 2021/06/07(月) 17:32
（もこな２） 2021/06/07(月) 17:40
そもそも大前提の０以外の転記がないので💦
（やす） 2021/06/07(月) 17:46
で、直しましたがエラーは出ませんが反映されなくなりました。
（やす） 2021/06/07(月) 17:54
条件を与えるセル領域をどこかに用意できるなら、 AdvancedFilter使うのが楽ですよ （´・ω・`） 2021/06/07(月) 17:59
これだけでもかなり改善されるのでは。 他は知らない。
> For k = 6 To n > Cells(k, "AB") = Cells(k, "R") > Cells(k, "AC") = Cells(k, "S") > Cells(k, "AD") = Cells(k, "T") > Cells(k, "AE") = Cells(k, "U") > Cells(k, "AF") = Cells(k, "V") > Cells(k, "AG") = Cells(k, "W") > Cells(k, "AH") = Cells(k, "X") > Cells(k, "AI") = Cells(k, "Y") > Next k
For k = 6 To n
redim TB(1 to 8)
TB(1) = Cells(k, "R")
TB(2) = Cells(k, "S")
TB(3) = Cells(k, "T")
TB(4) = Cells(k, "U")
TB(5) = Cells(k, "V")
TB(6) = Cells(k, "W")
TB(7) = Cells(k, "X")
TB(8) = Cells(k, "Y")
Cells(k, "AB").resize(,8).value = TB
Next k
（JPS） 2021/06/07(月) 18:03
＞Range(Cells(k,"AB"),cells(k,"AI")) = Range(Cells(k,"R"),Cells(k,"Y"))
なんか奇異な感じがする。
右辺が単セルじゃない場合は、Rangeオブジェクトでは渡せないハズ。 右辺は「.Value」プロパティにすべき。
いずれにしても、For k = 6 To n は冗長な気がする。
＞ For k = 6 To n ＞ Cells(k, "AB") = Cells(k, "R") ＞ Cells(k, "AC") = Cells(k, "S") ＞ Cells(k, "AD") = Cells(k, "T") ＞ Cells(k, "AE") = Cells(k, "U") ＞ Cells(k, "AF") = Cells(k, "V") ＞ Cells(k, "AG") = Cells(k, "W") ＞ Cells(k, "AH") = Cells(k, "X") ＞ Cells(k, "AI") = Cells(k, "Y") ＞ Next k
そのループ処理は、こんなので一発じゃないですか？（実地検証してないですけど）
If 6 <= n Then
Cells(6, "AB").Resize(n - 5) = Cells(6, "R").Resize(n - 5).Value
End If
（半平太） 2021/06/07(月) 18:15
＞ If 6 <= n Then ＞ Cells(6, "AB").Resize(n - 5) = Cells(6, "R").Resize(n - 5).Value ＞ End If
間違えました。m(__)m
If 6 <= n Then
Cells(6, "AB").Resize(n - 5, 8) = Cells(6, "R").Resize(n - 5, 8).Value
End If
（半平太） 2021/06/07(月) 18:33
★２
基本的な話は[[20210603152142]]で述べたと思うので割愛。
（ちょっと列を間違えていたので修正しました）
そして、このトピックを拝見していて、何も10000行目まで処理する必要はないんじゃないかなとおもったのでそこも修正。
Sub さんぷる()
Dim n As Long
Dim MyRNG As Range
Dim myUnion As Range
If MsgBox("実行すると戻せません。実行しますか？", vbYesNo) = vbNo Then
MsgBox "中止しました。"
Exit Sub
End If
With ActiveSheet
n = .Cells(.Rows.Count, "B").End(xlUp).Row
If n >= 6 Then
'★１
.Range("AB6:AI" & n).Value = Range("R6:Y" & n).Value
'★２
For Each MyRNG In .Range("V6:V" & n) '←前トピックで列を間違えていたので修正
If MyRNG.Value = MyRNG.Offset(, 1).Value Then
If myUnion Is Nothing Then
Set myUnion = MyRNG
Else
Set myUnion = Union(myUnion, MyRNG)
End If
End If
Next MyRNG
If Not myUnion Is Nothing Then
Intersect(MyRNG.EntireRow, .Range("B6:AI10000")).Copy Worksheets("R3.10").Range("B6")
End If
MsgBox "実行しました｡"
End If
End With
End Sub
以下余談。
ニックネームをコロコロ変えるのはお勧めしません。 （同じ説明をしてもされてもつまらないでしょう。）
別のニックネームで投稿されたトピックにも返答がついてるのですからきちんと処理（返答）したほうがよいように思います。
なおしちゃいましたが↓の位置について、【ステップ実行】してよく検討してみてはどうですか？ MsgBox "実行しました｡"
（もこな２） 2021/06/07(月) 21:59
ご提示のコードにてエラーがでました。
Intersect(MyRNG.EntireRow,.Range("B6:AI10000")).CopyWorksheets("R3.10").Range("B6")
オブジェクト変数またはWithブロック変数が設定されていません。
です。
宜しくお願いします。
（やす） 2021/06/08(火) 08:51
誤 Intersect(MyRNG.EntireRow,.Range("B6:AI10000")).Copy Worksheets("R3.10").Range("B6")
正 Intersect(myUnion.EntireRow,.Range("B6:AI10000")).Copy Worksheets("R3.10").Range("B6")
ですね。（前トピックでも提示してますし、何をやってるか理解出来ていれば自力で修正できたとおもいますが。。。）
（もこな２） 2021/06/08(火) 09:49
押しつけのように任されたもので頼るすべがなくこちらにすがっています。
ご提示のコードではV-W=0のデータが転記されてしまいました。
V-W≠0のデータを転記したいです。
宜しくお願いします。。。
（やす） 2021/06/08(火) 10:02
Sub 転記用09月()
Dim MyRNG As Range
Dim myData As Variant
Dim myUnion As Range
Dim n
Dim k
Dim i As Long
If MsgBox("実行すると戻せません。実行しますか？", vbYesNo) = vbNo Then
MsgBox "中止しました。"
Exit Sub
End If
With ActiveSheet
n = .Cells(.Rows.Count, "B").End(xlUp).Row
If n >= 6 Then
.Range("AB6:AI" & n).Value = Range("R6:Y" & n).Value
Set MyRNG = Range("B6:AI10000") '表の範囲
myData = Range("V6:W10000").Value '比べる列
For i = LBound(myData) To UBound(myData)
If myData(i, 1) <> myData(i, 2) Then
If myUnion Is Nothing Then '最初に見つかったとき
Set myUnion = MyRNG.Rows(i)
Else
Set myUnion = Union(myUnion, MyRNG.Rows(i))
End If
End If
Next i
If Not myUnion Is Nothing Then
myUnion.Copy Worksheets("R3.10").Range("B6") 'コピー先
End If
MsgBox "実行しました｡"
End If
End With
End Sub
です。
手直ししたほうがいいところあれば追記お願いします。
（やす） 2021/06/08(火) 11:55
＞ご提示のコードではV-W=0のデータが転記されてしまいました。
たびたび失礼。こちらも打ち直したときにミスってますね。
誤 If MyRNG.Value = MyRNG.Offset(, 1).Value Then 正 If MyRNG.Value <> MyRNG.Offset(, 1).Value Then
＞手直ししたほうがいいところあれば
「何も10000行目まで処理する必要はないんじゃないか」とコメントしましたが実際のところどうなんですか？
「軽く」というのがどういうことなのかわかりませんが、軽快な動作という意味なら必要の無い比較はしないほうがいいでしょうし、スマートな記述にしたいという意味なら一度しか使わないセル範囲をいちいち変数に格納するのもどうかなぁと思いますが。
（もこな２） 2021/06/08(火) 12:37
10000行はあくまでも目安の行数です。
そこは可変なので変数に置き換えます。
いろいろとありがとうございました。
（やす） 2021/06/08(火) 13:04
＞10000行はあくまでも目安の行数です。
それなら、やはり求めたn行目まで処理すれば探す作業は終わりにしてよいのでは？
Option Explicit
Sub オマケ()
Dim i As Long, n As Long, MyRNG As Range
Stop 'ブレークポイントの代わり
If MsgBox("実行すると戻せません。実行しますか？", vbYesNo) = vbNo Then
MsgBox "中止しました。"
Exit Sub
End If
With ActiveSheet
n = .Cells(.Rows.Count, "B").End(xlUp).Row
If n < 6 Then
MsgBox "データがありません"
Exit Sub
End If
.Range("AB6:AI" & n).Value = Range("R6:Y" & n).Value
For i = 6 To n
If .Cells(i, "V").Value - .Cells(i, "W").Value <> 0 Then
If MyRNG Is Nothing Then
Set MyRNG = .Rows(i)
Else
Set MyRNG = Union(MyRNG, .Rows(i))
End If
End If
Next i
If MyRNG Is Nothing Then
MsgBox "コピー条件に該当する行はありません"
Else
Intersect(MyRNG, .Range("B:AI")).Copy Worksheets("R3.10").Range("B6")
MsgBox "実行しました。"
End If
End With
End Sub
（もこな２） 2021/06/08(火) 18:27
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.