古いデータを別シートに移動させる場合の高速化

Question

コード
エクセルで表のような商品の表を作成しています。

A　　　　　　　B　　　　　C　　　　D　　　　　E
商品コード　　商品名 成分 成分比率 　　更新日付
aaa 　　　　商品A a 　　0.7 　　　　2020/1/10
aaa 　　　　商品A b 　　0.3 　　　　2020/1/10
bbb 　　　　商品B c 　　0.5 　　　　2020/1/11
bbb 　　　　商品B d 　　0.5 　　　　2020/1/11
ccc 　　　　商品C f 　　1 　　　　　　2020/1/20
aaa 　　　　商品A a 　　0.6 　　　　2020/3/5
aaa 　　　　商品A b 　　0.4 　　　　2020/3/5
ddd 　　　　商品D a 　　0.4 　　　　2020/3/12
ddd 　　　　商品D f 　　0.6 　　　　2020/3/12
ccc 　　　　商品C s 　　1 　　　　2020/3/20

成分を色々調整しており、古いデータは別のシートに移動させたく次のようなコードを作成しました。
①コード、日付でソートする。
②コードが同じで日付が異なる箇所のコード、日付を記憶させF列に旧版と記載する。
③F列が旧版の列を別シートにコピーし削除する。
④日付でソートする。

これで思い通りには動くのですが、1000以上のデーターでは20分以上掛かり困っています。初心者のためこの程度のコードしか書けないのですが、高速化できる方法があるでしょうか。よろしくお願いします。
環境：Excel2010、Windows7

Sub 移動()
    Application.ScreenUpdating = False
    Dim txt As String, txt2 As String
    Dim i As Long, j As Long
    Dim ws As Worksheet, ws2 As Worksheet
    Set ws = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("A1"), Order:=xlAscending
            .Add Key:=ws.Range("E1"), Order:=xlAscending
        End With
        .SetRange ws.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlYes
        .Apply
    End With
    With ws
        For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(i, 1) = .Cells(i + 1, 1) And .Cells(i, 5) <> .Cells(i + 1, 5) Then
                txt = .Cells(i, 1)
                txt2 = .Cells(i, 5)
                For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
                    If .Cells(j, 1) = txt And .Cells(j, 5) = txt2 Then
                        .Cells(j, 6) = "旧版"
                    End If
                Next j
            End If
        Next i
    End With
    For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        If ws.Cells(i, 6) = "旧版" Then
            ws.Rows(i).Copy
            Sheets("Sheet2").Select
            ws2.Rows(ws2.Cells(Rows.Count, 1).End(xlUp).Row).Offset(1, 0).Insert Shift:=xlDown
            ws.Rows(i).Delete Shift:=xlUp
        End If
    Next i
    ws.Select
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("E1"), Order:=xlAscending
        End With
        .SetRange ws.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlYes
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub

Answer 1

dictionayを使用してみました。
これで2重ループが１回ですむかと。
以下のようになります。

Sub 移動()
    Application.ScreenUpdating = False
    Dim txt As String, txt2 As String
    Dim i As Long, j As Long
    Dim ws As Worksheet, ws2 As Worksheet
    Dim dicT As Object      'キー 商品コード　値：更新日付
    Dim key As Variant
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    
    Set ws = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    With ws.Sort
        With .SortFields
            .Clear
            .Add key:=ws.Range("A1"), Order:=xlAscending
            .Add key:=ws.Range("E1"), Order:=xlAscending
        End With
        .SetRange ws.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).row)
        .Header = xlYes
        .Apply
    End With
    With ws
        For i = .Cells(Rows.Count, 1).End(xlUp).row To 2 Step -1
            key = .Cells(i, 1)
            If dicT.exists(key) = True Then
                If dicT(key) <> .Cells(i, 5) Then
                    .Cells(i, 6) = "旧版"
                End If
            Else
                dicT(key) = .Cells(i, 5)
            End If
        Next
    End With
    For i = ws.Cells(Rows.Count, 1).End(xlUp).row To 2 Step -1
        If ws.Cells(i, 6) = "旧版" Then
            ws.Rows(i).Copy
            Sheets("Sheet2").Select
            ws2.Rows(ws2.Cells(Rows.Count, 1).End(xlUp).row).Offset(1, 0).Insert Shift:=xlDown
            ws.Rows(i).Delete Shift:=xlUp
        End If
    Next i
    ws.Select
    With ws.Sort
        With .SortFields
            .Clear
            .Add key:=ws.Range("E1"), Order:=xlAscending
        End With
        .SetRange ws.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).row)
        .Header = xlYes
        .Apply
    End With
    Application.ScreenUpdating = True
End Sub

Comments

[Taka1108]

回答ありがとうございました。
Dictionaryを使った方法勉強になりました。

Answer 2

①コード、日付でソートする。

②コードが同じで日付が異なる箇所のコード、日付を記憶させF列に旧版と記載する。
③F列が旧版の列を別シートにコピーし削除する。
④日付でソートする。

① と ④ はそんなに時間がかかっていないし、大幅なの高速化はないでしょう。

② と ③ で時間がかかっていると予想されます。
まずは、② の高速化のロジックを考えてみました。

日付が昇順に並んでいるなら、ループをは後ろから走査した方がシンプルかつ高速になりそうです。
Boolean型の旧版判定変数を、
商品コードがブレーク(変化したら)したら False
日付がブレークしたら True にするというロジックにしました。

Sub 移動()
    '略 ①

    With ws
        Dim old As Boolean ’旧版判定
        For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
            If .Cells(i, 1) <> .Cells(i - 1, 1) Then '商品コードブレーク
                old = False
            ElseIf .Cells(i, 5) <> .Cells(i - 1, 5) Then '更新日ブレーク
                old = True
            End If
            
            If old Then .Cells(i - 1, 6) = "旧版"
        Next i
    End With

    '略 ③ ④

End Sub

③ の旧版のコピー/削除は、１行ずつコピー/削除するのではなく、AutoFilter で旧版のデータのみに絞り込んでから、コピー/削除すれば１回で済みますので、高速化になると思います。

    With ws.Range("A2:F" & ws.Cells(Rows.Count, 1).End(xlUp).Row)
        .AutoFilter Field:=6, Criteria1:="=旧版"
        .Copy ws2.Range("A2")
        .EntireRow.Delete
        .AutoFilter
    End With

---

② の旧版判定のコードを配列を使ったものにしてみました。セル参照なしでメモリー上での処理になるのでさらに高速化できると思います。

    Dim rng As Range, ary() As Variant
    Set rng = ws.Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
    ary = rng.Value '表データを配列に格納
    Dim old As Boolean
    For i = UBound(ary) To 2 Step -1
        If ary(i, 1) <> ary(i - 1, 1) Then '商品コードブレーク
            old = False
        ElseIf ary(i, 5) <> ary(i - 1, 5) Then '更新日ブレーク
            old = True
        End If
       
        If old Then ary(i - 1, 6) = "旧版"
    Next i
    rng.Columns(6).Value = Application.Index(ary, 0, 6) '配列の６列目を表の６列目に代入

Comments

[Taka1108]

回答ありがとうございました。
家のPCで別のデーターでトライしてみましたが
1000近いデーターで15秒近くかかっていたのが、1秒以下になりました。
会社のPCは家のPCよりも環境が悪く、実際のデーターも別ファイルに移動したりと色々あるので
明日会社でコードを修正します。

[Taka1108]

先週回答いただいて何の問題もなく作動するのですが、一つ疑問があります。

ElseIf .Cells(i, 5) <> .Cells(i - 1, 5) Then '更新日ブレーク
old = True
If old Then .Cells(i - 1, 6) = "旧版"

下のデーターで20204/10から20203/3に切り替わるところはCells(i, 5)<>Cells(i - 1, 5)でTrueなのですが、それより上はすべて20203/3なのでCells(i, 5) = Cells(i - 1, 5)となりFalseにならないのでしょうか。
質問が分かりにくいかもしれませんが、どうしてもこの部分が理解できずにいます。
こちらの望む通りの動きをしているにもかかわらず、申し訳ありません。

商品コード 商品名 成分 成分比率 更新日付
aaa 　　　商品A a 0.5 　　　2020/3/3 　旧版
aaa 　　　商品A b 0.2 　　　2020/3/3 　旧版
aaa 　　　商品A c 0.3 　　　2020/3/3 　旧版
aaa 　　　商品A a 0.3 　　　2020/4/10
aaa 　　　商品A b 0.2 　　　2020/4/10
aaa 　　　商品A c 0.3 　　　2020/4/10
aaa 　　　商品A d 0.2 　　　2020/4/10
ccc 　　　商品C a 1 　　　2020/1/10

[hatena19]

> それより上はすべて20203/3なのでCells(i, 5) = Cells(i - 1, 5)となりFalseにならないのでしょうか。

Cells(i, 5)<>Cells(i - 1, 5) の時は、old を True に変更するが、
Cells(i, 5) = Cells(i - 1, 5) の時は、何もしない、つまり、old は True のまま変化しない、
ということです。

言葉では分かりにくい場合は、ブレークポイントをその行に設定して、ステップ実行しながら、変数の値がどうなっているか確認するというデバッグ作業をすると理解しやすいと思います。

【超初心者向け】エクセルVBAでデバッグをする方法を解説します
https://www.excelspeedup.com/vbadebug/

[Taka1108]

ありがとうございました。納得できました。

Answer 3

ループ回数を減らしました。どのぐらい速くなるかは分かりませんが、どうでしょうか？

Sub test()

    Dim txt As String, txt2 As String
    Dim i As Long, j As Long
    Dim ws As Worksheet, ws2 As Worksheet
    Set ws = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range("A1"), Order:=xlAscending
            .Add Key:=ws.Range("E1"), Order:=xlDescending
        End With
        .SetRange ws.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlYes
        .Apply
    End With
    
    With ws
        txt = .Cells(2, 1).Value
        txt2 = .Cells(2, 5).Value
        For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(i, 1).Value <> txt Then
                txt = .Cells(i, 1).Value
                txt2 = .Cells(i, 5).Value
            ElseIf .Cells(i, 5).Value <> txt2 Then
                .Cells(i, 6) = "旧版"
                ws.Rows(i).Copy
                ws2.Rows(ws2.Cells(Rows.Count, 1).End(xlUp).Row).Offset(1, 0).Insert Shift:=xlDown
                ws.Rows(i).Delete Shift:=xlUp
                i = i - 1
            End If
        Next i
    End With

End Sub

---

Forループを2回しているので、1回にしてはどうでしょうか？
検証はしていませんが下記の様になるかと思います。

If .Cells(j, 1) = txt And .Cells(j, 5) = txt2 Then
    .Cells(j, 6) = "旧版"
    .Rows(j).Copy
    ws2.Rows(ws2.Cells(Rows.Count, 1).End(xlUp).Row).Offset(1, 0).Insert Shift:=xlDown
    .Rows(j).Delete Shift:=xlUp
End If

Comments

[Taka1108]

回答ありがとうございます。
検証してみましたが、商品Aの成分が二つあり、1行が移動されず残ったままになります。
ループを1回省略したことで、成分が二つあるものは一つの成分しか移動されないようです。

商品コード 商品名 成分 成分比率 更新日付
aaa 商品A b 0.3 2020/1/10
bbb 商品B c 0.5 2020/1/11
bbb 商品B d 0.5 2020/1/11
aaa 商品A a 0.6 2020/3/5
aaa 商品A b 0.4 2020/3/5
ddd 商品D a 0.4 2020/3/12
ddd 商品D f 0.6 2020/3/12
ccc 商品C s 1 2020/3/20

[tatsu99]

商品コード 商品名 成分 成分比率 更新日付
aaa 商品A b 0.3 2020/1/10・・・①
aaa 商品A b 0.3 2020/1/10・・・②
bbb 商品B d 0.5 2020/1/11
aaa 商品A a 0.6 2020/3/5・・・③
aaa 商品A b 0.4 2020/3/5・・・④
ddd 商品D a 0.4 2020/3/12
ddd 商品D f 0.6 2020/3/12
ccc 商品C s 1 2020/3/20
商品Aについてですが、上記の場合、残す（移動しない）のは①～④のどれでしょうか？

[Taka1108]

残すのは日付が新しい③と④です。よろしくお願いします。

[Taka1108]

回答ありがとうございました。
今後はループを少なく作成するように勉強していきます。

Answer 4

解決済みですが、すっごい気になるので。。。。

VBAで悩む前に手動でさくっとやっつけたいですね。

Sub test()
    Dim i As Long

    For i = 1 To 2
        Worksheets(1).Copy After:=Worksheets(i)
        With Worksheets(i + 1).UsedRange
            .Sort Key1:=.Cells(.Columns.Count), Order1:=i, Header:=xlYes
            .RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
            If i = 2 Then
                .Sort Key1:=.Cells(.Columns.Count), Order1:=xlAscending, Header:=xlYes
            End With
        End With
    Next
End Sub