VBA 差分抽出

Question

お世話になっております。

VBAで差分抽出マクロを作成しております。
まだまだ、VBA学習中で、配列やオブジェクト、コレクションを使いこなせない
ので、ループ処理やcells(x.y)だけで差分抽出マクロを作成しよとしておりますが、
訳がわからなくなってきてしまいました。

＜やりたい処理＞
①作業前後のデーターで差分を取り、作業後に出た差分を切り取り、別のセルに移動させる。
②作業前のデーターの行の並び順(位置）と同じ並び(順）にする。

イメージは、以下の画像を参照して下さい。

Answer 1

質問の例ですと、以下のコードで動作します。
簡単なコードで書くようにしましたので内容を解析してみて、
実際のデータで処理する際のご参考にしてください。

<前提>
・作業前のデータは、AとB列で3行目から開始されている
・作業後のデータは、DとE列で3行目から開始されている
・作業後の並替済データは、G列とH列で3行目から書き込まれる
・作業後の差分データは、J列とK列で3行目から書き込まれる

Public Sub sample()
    
    Dim i As Integer '作業前のデータの位置
    Dim j As Integer '作業後のデータの位置
    Dim k As Integer '差分データを貼付る位置
    
    Cells(1, 7) = "作業後(並替え)"
    Cells(1, 10) = "差分"
    
    '作業前と作業後のデータを総当りでチェックして同じものはTrueを目印として書き込む
    i = 3
    Do While Cells(i, 1) <> ""
        j = 3
        Do While Trim(Cells(j, 4)) <> ""
            'データが一致しているかの判断
            If Cells(i, 1) = Cells(j, 4) And Cells(i, 2) = Cells(j, 5) Then
                '目印にTrueを付ける
                Cells(i, 3) = True
                Cells(j, 6) = True
                '作業後のデータを作業前のデータと同じ位置にコピー(7～8列目)
                Range(Cells(j, 4), Cells(j, 5)).Copy
                Cells(i, 7).Select
                ActiveSheet.Paste
            End If
            j = j + 1
        Loop
        i = i + 1
    Loop
    
    '作業後のデータで目印にTrueがつかなかったものは差分データにコピー(10～11列目)
    j = 3
    k = 3
    Do While Cells(j, 4) <> ""
        If Cells(j, 6) = False Then
            Range(Cells(j, 4), Cells(j, 6)).Copy
            Cells(k, 10).Select
            ActiveSheet.Paste
            k = k + 1
        End If
        j = j + 1
    Loop
    
    '作業前のデータで目印にTrueがつかなかったものも差分データにコピー(10～11列目)
    i = 3
    Do While Cells(i, 1) <> ""
        If Cells(i, 3) = False Then
            Range(Cells(i, 1), Cells(i, 3)).Copy
            Cells(k, 10).Select
            ActiveSheet.Paste
            k = k + 1
        End If
        i = i + 1
    Loop
    
    '作業後の並べ替えたデータで空白がある場合(作業前のデータにしかなかった時)の空白を削除
    Dim l As Integer
    Dim m As Integer
    m = 3
    For l = 3 To i
        If Cells(m, 7) = "" Then
            Range(Cells(m, 7), Cells(m, 8)).Delete xlShiftUp
        Else
            m = m + 1
        End If
    Next l
    
    '目印に付けたTrueを消す(比較結果をデバッグしたい場合はここはコメントアウトする)
    Range("C:C").ClearContents
    Range("F:F").ClearContents
End Sub

Comments

[退会済みユーザー]

作業前と作業後のデータを総当りでチェックのループですが、
作業後のデーターの方が多いので、 Do While Trim(Cells(j, 4)) <> ""を外側にするべきではないのでしょうか？？

[退会済みユーザー]

提示頂いたすべての処理を理解するのは大変なので、ちょっと短くしてみたのですが、
なぜか、総当りチェックができずに、とまってしまいます。なぜでしょうか？？

Sub test()
Dim i As Long　’作業前データー
Dim j As Long　'作業後データー

i = 3
j = 3

Do While Cells(i, 1) <> ""
Do While Cells(j, 4) <> ""
If Cells(i, 1) = Cells(j, 4) Then
Cells(j, 6) = "●"
End If
j = j + 1
Loop
i = i + 1
Loop
End Sub

[_kato]

まず作業前や作業後のデータ内で同じデータがないのであれば総当たりチェックする
必要がなく、If Cells(i, 1) = Cells(j, 4) Thenでヒットした後に次のデータに移る
ようにすれば処理は早くなりますね。
Cells(j, 6) = "●"の後に、j=50000などデータがない大きな値をセットすれば
ループを抜けれますね。

総当たりする必要がある場合は、データの件数が多いのであれば時間はかかると
思います。動いているのか、無限ループになっているのかはブレークポイントを
設定してデバッグして確認してみて下さい。

上記のコードで無限ループになるとすれば、データが終わっているにもかかわらず
Cells(i, 1) <> ""　や　Cells(j, 4) <> ""　にならないデータが続いているのでは
ないでしょうか？

作業後のループを外にするかどうかは、関係ないと思います。