VBA データ抽出速度改善

Question

VBAを使用して複数シートから別ブックのシートにデータ抽出するために色々と調べ自作したのですが、処理速度が遅く困っております。

マスターデータには仕入れリスト2月～12月、品目コード、拠点担当者名一覧のシートがあります。

別ブックのシート１に抽出する際下記の方が早いでしょうか。
マスターデータの仕入れリスト2月～12月シートからI列に品名の記載がある場合、
マスターデータのC~E列、I列、L列、N~O列を、シート１のA~G列に順に抽出
２月抽出データの下に3月データ、4月データと続くように抽出


現状は
マスターデータの仕入れリスト2月～12月シートからI列に品名の記載がある場合、
指定セルに順に抽出している状況です。

ファイル添付しますので、
処理速度が今より早くなる方法があれば、ご教授頂きたいです。
※添付ファイルですが質問用に変更したため、シート名の抽出が異なります。

下記に実際のコードも添付させていただきます。
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
Option Explicit
 Sub マスターデータ取込01()  '指定したファイルを取り込み、別のファイルに貼り付ける。
 Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

    Dim SetFile As String
    Dim wbMoto, wbSaki As Workbook
    Dim wstData As Worksheet
    Dim wstAnsw As Worksheet
    Dim lngWRow As Long
    Dim lngRRow As Long
    Dim r As Long
    Dim wsname As String
    wsname = "仕入れリスト"
 
    Set wbMoto = ActiveWorkbook  'マスターデータ取り込み元をブック名をセット（取り込み元）
 
    Set wstData = wbMoto.Worksheets("Sheet1")
    
   With wstData
        .Rows("2:" & .Rows.Count).ClearContents
    End With

   lngWRow = 2　　　　　　　
 
    Application.DisplayAlerts = False
       
    SetFile = 販売リスト.xlsx"  'マスターデータファイルの取り込み場所をセット（取り込み先）
    
    Workbooks.Open Filename:=SetFile, ReadOnly:=True, UpdateLinks:=0 'マスターデータファイルを読み取り専用で開きます（）
    Set wbSaki = Workbooks.Open(SetFile) '開いたマスターブック名とセット（取り込み先）
    
    For Each wstAnsw In Worksheets
    With wstAnsw
        If .Name Like "*" & wsname & "*" Then
         For r = 6 To .Cells(Rows.Count, 10).End(xlUp).Row     'シートの6行目から最終行目までのレコードを読み取る処理
                    If .Cells(r, 9) <> "" Then                         　　 '「品目」に記載がある場合
                        wstData.Cells(lngWRow, 1) = .Cells(r, 3)        '担当名転記
                        wstData.Cells(lngWRow, 2) = .Cells(r, 4)        '仕入先転記
                        wstData.Cells(lngWRow, 3) = .Cells(r, 5)        '仕入先担当転記                       
　　　　　　　　wstData.Cells(lngWRow, 4) = .Cells(r, 9)       '品目転記
                        wstData.Cells(lngWRow, 5) = .Cells(r, 12)       'ステイタス転記
                        wstData.Cells(lngWRow, 6) = .Cells(r, 14)       '仕入れ日転記
                        wstData.Cells(lngWRow, 7) = .Cells(r, 15)        '販売店舗転記
                         wstData.Cells(lngWRow, 8) = .Name　　　　　'シート（仕入れた月）名転記
          lngWRow = lngWRow + 1                                           '書込み行を次の行へ進める
 
    Application.DisplayAlerts = True
    Exit For
                    End If
                Next
            End If
        End With
    Next
wbSaki.Close False  'マスターデータ取り込み先のファイルを閉じる
 Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

 
End Sub

fujillin · Accepted Answer

No3です

＞支障なくデータ転記することが出来ました！
肝心の、速度の向上は実現できたのたでしょうか？？

＞Value値を代入する方法に変える場合を宜しければお教えいただきたいです。
ご質問のコードでもお示しのように
　Range.Value = Range.Value
の形式で行うのが普通だと思います。
ただし、この場合は、右辺はもちろんですが、左辺のRangeの範囲もきちんと設定しておくことが必要になります。
（コピペの場合は、元のサイズと同じ大きさの範囲にペーストされるので、気にしなくても良いのですが）
また、こちらの場合は、飛び飛びのセル範囲の値をまとめて転記はできませんので、連続するセル範囲毎に転記してゆく必要があります。
（結果的に、シートへのアクセス回数は少し増加する傾向にあります）

No3のコードの例で言えば、
　rDest.Resize(n, 3).Value = sht.Range("C6:E6").Resize(n).Value
　rDest.Offset(, 3).Resize(n).Value = sht.Range("I6").Resize(n).Value
　　・・・・・・
といった感じで記してゆけばよろしいかと。

別の方法としては、セルをコピーしておいてから「値をペースト」でまとめてペーストする方法も考えられます。
　rDest.PasteSpecial (xlPasteValues)
の一行で済むことは済むのですが、クリップボード経由のコピペになってしまうため、CutCopyMod=Falseにしておかないと、ブックを閉じる際に警告が出るなどの可能性が高くなります。
また、手操作とほぼ同じ処理になるので、（コードに明示しなくても）対象シートが（勝手に）アクティブになってしまうなどもあります。

peavy · Answer

Variantデータ型を使用するのが良いのではないでしょうか

fujillin · Answer

こんばんは

エクセル環境が手元にないので、考え方だけになってしまいますが･･･

きちんとは見ていませんが、ざっとみたところ各シートの一部のセル値をシート1に転記してまとめているだけと解釈しました。
（I列の項目名に関しては後述します）

一方で、VBAの実行速度はシートへのアクセス回数に大きく影響されます。
ご提示のコードでは、セルひとつひとつを転記していますが、列単位で（連続している列は複数列まとめて）転記することで、大幅に短縮が可能と思います。
セル範囲の計算に若干の手間がかかるかも知れませんが、速度的には圧倒的に速くなるはずです。
セル範囲をまとめるため、この時にはI列の判断をせずに列全体を転記してしまいます。
（まとめシートの行数がオーバーフローしないと仮定できることが条件）

最後に、まとめシート上でI列に値のない行を、全シート分まとめて削除します。
この処理を行う際も、1行ずつ削除するのではなく、
　Cmlumns(9).SpecialCells(xlcelltypeblanks)
などで空白セルをまとめて、その行を削除してしまえばシートへのアクセスは2回で済んでしまいます。

このようにすることで、シートへのアクセス回数が大幅に減少すると考えられますので、実行速度の向上が見込めるはずと思います。

fujillin · Answer

No2です

回答した手前、簡略化したものを作成してみました。

ご提示のコードから正しく読み取れているかわかりませんが、もし違っていても若干の調整で可能ではないかと想像します。

※ セル位置等を誤解しているかもしれませんので、テスト用のデータでテストしてみてください。
※ 簡略化の為、データの転記をコピペで行っていますが、関数等が入っているなどでコピペではまずい場合は、Value値を代入する方法に変える必要があります。
※ 以下のコードでは、データブックは開いていないものとしてOpenし、作業終了後閉じています。
　（データファイルは同じフォルダ内にあるものと仮定しています）
※ ScreenUpdating = False などの処理は除いてあります。
　 入れれることで若干速くなることが期待できます。

Sub Sample_11987039()
Dim wb As Workbook, sht As Worksheet
Dim rDest As Range, n As Long

Const wstData = "Sheet1"  'まとめ記入用シート名
Const wsname = "*仕入れリスト*"　'データ対象シート識別子
Const dataPath = "hoge.xlsx" 'データファイルのファイル名

Set rDest = Worksheets(wstData).Range("A2")
rDest.Worksheet.UsedRange.Offset(1).ClearContents
Set wb = Workbooks.Open(ThisWorkbook.PATH & "\" & dataPath, 0, 1)
 
For Each sht In wb.Worksheets
　If Not sht.Name Like wsname Then GoTo continue
　n = sht.Cells(Rows.Count, 10).End(xlUp).Row - 5
　If n < 1 Then GoTo continue
　Intersect(sht.Range("C:E,I:I,L:L,N:O"), sht.Range("A6:O6").Resize(n)).Copy Destination:=rDest
　rDest.Offset(, 7).Resize(n).Value = sht.Name
　Set rDest = rDest.Offset(n)
continue:
Next sht

wb.Close False
Set rDest = rDest.Worksheet.Range("D2").Resize(rDest.Row - 1)
rDest.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

VBA データ抽出 速度改善

Variantデータ型を使用するのが良いのではないでしょうか

こんばんは

No2です

No3です

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

VBA データ抽出速度改善