質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.04%

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

解決済

回答 4

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 889

score 32

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

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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 4

checkベストアンサー

+1

①コード、日付でソートする。
②コードが同じで日付が異なる箇所のコード、日付を記憶させ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

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

    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) '配列の6列目を表の6列目に代入

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/04/12 20:47

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

    キャンセル

  • 2020/04/17 18:37

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

    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

    キャンセル

  • 2020/04/17 21:40

    > それより上はすべて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/

    キャンセル

  • 2020/04/18 15:00

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

    キャンセル

+1

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

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

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/04/12 16:35 編集

    回答ありがとうございます。
    検証してみましたが、商品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

    キャンセル

  • 2020/04/12 18:45 編集

    商品コード 商品名 成分 成分比率 更新日付
    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についてですが、上記の場合、残す(移動しない)のは①~④のどれでしょうか?

    キャンセル

  • 2020/04/12 19:21

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

    キャンセル

  • 2020/04/12 20:44

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

    キャンセル

+1

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/04/12 20:35

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

    キャンセル

0

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

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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.04%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る