ループ処理がうまくいかない

Question

ここで教えて頂きながら、下記作業のマクロを作っているのですが、わからないところが出てきました。
コード内のコメント部分なのですが、自分でコードを書いてみましたがうまくいきません。
どなたかご教授いただけないでしょうか。

①Sheet1の品番とSheet2の品番が一致すれば、Sheet2の日付に本日を入れる
②Sheet1の品番がSheet2に存在しなければ、Sheet2の最終行をコピーして、Sheet2の最終行＋１に貼り付ける
Sheet2に貼り付けた行のセル値をSheet1の値に書き換える
※数式をコピーしたいので、上記手順をとっています。
Sheet１
品番｜名称｜コメント｜
001｜aaa｜あああ｜
003｜ccc｜ううう｜/
004｜ddd｜えええ｜
005｜eee｜かかか｜
Sheet2
日付｜品番｜名称｜コメント｜数式｜数式2｜・・・続く
0512｜001｜aaa｜あああ｜数式｜数式2｜・・・続く
｜002｜bbb｜いいい｜数式｜数式2｜・・・続く
0512｜003｜ccc｜ううう｜数式｜数式2｜・・・続く
0512｜004｜ddd｜えええ｜数式｜数式2｜・・・続く

下記コードでうまくいかないこと
・Elseの場合に、１つ目しかコピーできない。n=n+1といれてみたがうまくいかない
・最終行をコピーして、最終行＋１に貼り付けた行のセル値を書き換えたいがうまくいかない

sub test()
dim i as long
dim j as long

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
n = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1

For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
For j = 2 To ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row

If ws1.Cells(i, 1).Value = ws2.Cells(j, 2).Value Then
   ws2.Cells(j, 1).Value = Date
Else
’品番が一致しなければ、最終行をコピーして、＋１行目に貼り付ける
’※１つ目しか貼りつかない（ループ処理がうまくいかない）
   ws2.Rows(n - 1).Copy Destination:=ws2.Rows(n)
’貼り付けた行のセルの値をSheet1の品番、名称、コメントに書き換えたいがうまくいかない
   ws2.cells(j,2).value = ws1.cells(i,1).value
   ws2.cells(j,3).value = ws1.cells(i,2).value
   ws2.cells(j,4).value = ws1.cells(i,3).value
　　
  ’ここに n = n + 1　をいれたりしてみたがうまくいかない

End If

Exit For

Next j
Next i

End Sub

Answer 1

Sub test()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Long
    Dim j As Long
    Dim k As Long

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        k = ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row  '最終行番号を記憶
        For j = 2 To k
            If ws1.Cells(i, 1).Value = ws2.Cells(j, 2).Value Then
                ws2.Cells(j, 1).Value = Date
                Exit For
            End If
        Next j

        'ループが最後まで回った(＝jの値がｋの値を越えた）ら新規データとして追記
        If j > k Then
            '品番が一致しなければ、最終行をコピーして、＋１行目に貼り付ける
            '※１つ目しか貼りつかない（ループ処理がうまくいかない）
            ws2.Rows(j - 1).Copy Destination:=ws2.Rows(j)
            '貼り付けた行のセルの値をSheet1の品番、名称、コメントに書き換えたいがうまくいかない
            ws2.Cells(j, 2).Value = ws1.Cells(i, 1).Value
            ws2.Cells(j, 3).Value = ws1.Cells(i, 2).Value
            ws2.Cells(j, 4).Value = ws1.Cells(i, 3).Value
        End If
    Next i
End Sub

If ws1.Cells(i, 1).Value = ws2.Cells(j, 2).Value Then

の時には、「あった」は解りますが、「なかった」は確定してません。
「あった」の時にはそこでループを抜けて、
最後までループを回ったら、「なかった」と判断したらいいと思います。

少ないサンプルデータで、
ステップインで1行ずつ実行してみて、
変数「J」の値の変化をローカルウィンドウで確認してみてください。

あと、コード見て
変数を上手く使えるとより良いと思いました。（特にオブジェクト型の変数）
今の書き方だと、たくさんのデータ量の時に動作が重くなる可能性があります。
以下サンプル
（処理速度がどれくらい改善されるかわかりませんが＾＾；）

Sub test2()
    Dim rngNew As Range
    Dim rngList As Range
    Dim c As Range
    Dim ixRow As Long
    
    Set rngNew = Worksheets("Sheet1").Range("A1").CurrentRegion
    
    For Each c In rngNew.Columns(1).Cells
        Set rngList = Worksheets("Sheet2").Range("A1").CurrentRegion
        On Error GoTo ErrLabel
        ixRow = WorksheetFunction.Match(c, rngList.Columns(2), 0)
        On Error GoTo 0
        
        With rngList.Rows(ixRow)
            .Cells(1).Value = Date
            .Range("B1:D1").Value = c.Resize(, 3).Value
        End With
    Next
    
    Exit Sub
    
ErrLabel:
        With rngList
            .Rows(ixRow).Resize(2).AutoFill .Cells, xlFillFormats
                        ixRow = .Rows.Count + 1
            Resume Next
        End With
End Sub

エクセルにはたくさんの関数が内包されています。
それを利用するとVBAでループ処理を書かなくて済むようになります。

勉強中なので何回でも0から書き直したほうがいいと思います。
結果が早く欲しいのは解りますが、
間違ったロジックで書いているものを部分部分で直していくと、
結局後で直したくなった時に読んでみてわからなくて、
1から書き直しになるので、、、
これくらいのマクロなら1からでも、サクッと書けるように、
何度でも1から書き直してみてはいかがでしょう？

※コンパイル＆動作確認してないので、バグがある可能性があります。

参考になれば。

Comments

[退会済みユーザー]

大変分かりやすくご説明いただき、ありがとうございます。
If j > k Thenの使い方もとても勉強になりました。
２つ目のコードも理解できるように、何度も０から書き直して勉強していきたいと思います。

Answer 2

入力箇所間違えました。

Answer 3

さくっと見た限り
Sheet1の品番がSheet2に存在しなければ
って書いてますので

For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    ' 存在チェックフラグ初期化(off)
For j = 2 To ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row
    ' 存在チェックしてフラグOnなどする(存在したらとっととjのループ抜けてもいいかと
Next j

    ' 存在チェック用フラグがOn/Offで処理を分ける
Next i

が正解なのではないでしょうか？
あとws1.Cells(ws1.Rows.Count, 1).End(xlUp).Rowなどは動的に変更しそうな気がするから変数代入してそれを利用したほうがいいかも

Comments

[退会済みユーザー]

ありがとうございます。
elseの前まではうまく動いています。
マクロを勉強中で、いちから変更するのは時間的に厳しいです。else以降のコード修正では難しいでしょうか…
ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Rowを変数代入するやり方は取り入れたいと思います。勉強になります。

[rururu3]

ws2.cells(j,2).value = ws1.cells(i,1).value
ws2.cells(j,3).value = ws1.cells(i,2).value
ws2.cells(j,4).value = ws1.cells(i,3).value

jではなくnではとも思う

[退会済みユーザー]

確かにそうでした。
貼りつけ先はnとしているのでnでした。少し進めました。ありがとうございます！！

else以降の作業を繰り返し行いたいのですが、n＝n＋1でいけないのでしょうか…

[rururu3]

最初の回答通りFor処理で間違えてるから１つ目しか貼り付けないとおもう…