VBA 別ブックからの転記の高速化について VBA 別ブックからの転記の高速化についてご教授下さい。

Question

VBA 別ブックからの転記の高速化について

VBA 別ブックからの転記の高速化についてご教授下さい。
現在、下記のようなコードで作業してるのですが、マクロの実行をするととても時間がかかり困ってます。転記元のデータ数が、日々増えており日に日にかかる時間が増えてます。良い方法はご教授いただきたいです。よろしくお願いします。
Option Explicit
Const Scrbook As String = "●●●.xlsx"
Const Folder As String = "○○○"
Public Sub sheet1() 
　Dim dict As Object
　Dim maxrow3 As Long
　Dim row3 As Long
　Dim key2 As Variant
　Dim sh3 As Worksheet
　Dim Vals As Variant
　Dim sname As String
　Dim row2 As Long
　
　Application.ScreenUpdating = False
　Application.Calculation = xlCalculationManual

Set dict = CreateObject("Scripting.Dictionary")
    Workbooks.Open Filename:=Folder & "\" & Scrbook, ReadOnly:=True, UpdateLinks:=0

Call GetlDs("●●●", dict)

ThisWorkbook.Activate
    Set sh3 = Worksheets("Sheet1")
    maxrow3 = sh3.Cells((Rows.Count), "F").End(xlUp).row

For row3 = 4 To maxrow3
    key2 = sh3.Cells(row3, "F").Value

If dict.exists(key2) = True And sh3.Cells(row3, "H") = "" Then
        Vals = Split(dict(key2), "|")
        sname = Vals(0)
        row2 = Vals(1)
        sh3.Cells(row3, "E").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "C").Value

sh3.Cells(row3, "G").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "Z").Value
        sh3.Cells(row3, "H").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "H").Value
        sh3.Cells(row3, "I").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "G").Value
        sh3.Cells(row3, "J").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "L").Value
        sh3.Cells(row3, "K").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "K").Value
        sh3.Cells(row3, "M").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "DQ").Value
        sh3.Cells(row3, "O").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "T").Value
        sh3.Cells(row3, "P").Value = Workbooks(Scrbook).Worksheets(sname).Cells(row2, "V").Value

Else
    'sh3.Cells(row, "E").Value = ""
    'sh3.Cells(row, "G").Value = ""
    'sh3.Cells(row, "H").Value = ""
    'sh3.Cells(row, "I").Value = ""
    'sh3.Cells(row, "J").Value = ""
    'sh3.Cells(row, "K").Value = ""
    'sh3.Cells(row, "M").Value = ""
    'sh3.Cells(row, "O").Value = ""
    'sh3.Cells(row, "P").Value = ""

End If
    Next
    Workbooks(Scrbook).Close

Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Private Sub GetlDs(ByVal sname As String, ByVal dict As Object)

Dim maxrow As Long
Dim row As Long
Dim key As Variant
Dim sh3 As Worksheet
Set sh3 = Worksheets(sname)
maxrow = sh3.Cells((Rows.Count), "A").End(xlUp).row 'ID
For row = 2 To maxrow
key = sh3.Cells(row, "A")
dict(key) = sname & "|" & row
Next

End Sub

tatsumaru77 · Accepted Answer

>「dict(key) = row1 - 2 + 1」のところがわかりません、もしよかったら教えて頂けませんか？
転記元の転記対象の列を全て、配列に入れて処理しています。
例として、2000行まであった場合、C列については、C2:C2000までを配列Carrに入れています。
配列Carrの先頭は、Carr(1,1)になります。
つまり
2行目のC2の値->Carr(1,1)
3行目のC2の値->Carr(2,1)
4行目のC2の値->Carr(3,1)
のようになります。
2行目のIDに対応する値は1なので、row1 - 2 + 1=1となります。
3行目のIDに対応する値は2なので、row1 - 2 + 1=2となります。
もし、5行目から開始しているなら、5行目が先頭なので
    For row1 = 5 To maxrow1
        key = sh1.Cells(row1, "A")
        dict(key) = row1 - 5 + 1
    Next
になります。

>速くなりました！
どのくらい、速くなったのでしょうか。具体的な数値を教えていただけるとありがたいです。
又、実行後、イミデイトウィンドウに
メモリ転記
Open           0.999999999996959 
GetIDs         0 
Sheet1         0 
のような数値が表示されますが、Open、GetIDs、Sheet1の値はいくつになってますでしょうか。

イミデイトウィンドウは、添付図のように
VBEの画面で、表示(V)->イミデイトウィンドウ(I)をクリックすると表示されます。

tatsumaru77 · Answer

No17でアップしたソースに誤りがありましたのでお詫びして訂正します。
こちらに変えてください。失礼しました。
https://ideone.com/BFxAls

変更箇所は、
６８，６９行の
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
です。
Application.Calculation = xlCalculationAutomaticがないと
excelが手動計算のままになってしまいます。

tatsumaru77 · Answer

>データの内容は変更しませんが、データ自体が増える事はあるので、こちらの方法は難しそうです。すみません、、、。

そうでしたら、メモリ上で、処理を行うようにするのが、残されている方法です。これでだめならこれ以上の対策は難しいかと思います。
下記にアップしました。
転記元のブックは転記元.xlsx、転記元のシート名は転記元にしてあります。
https://ideone.com/RVd8zQ

上記を実行すると、イミデイトウィンドウに例として以下のように表示されます。
メモリ転記
Open           0.999999999996959 
GetIDs         0 
Sheet1         1.00000000000655 
上記の値の合計が、処理時間になります。

tatsumaru77 · Answer

補足ありがとうございました。
>PCスペックですが、corei3の4Gでした。
全てメモリ上で行うようにして、効果があるかどうかは微妙です。
ちょっとメモリが足りないような気がしますが、効果があるかもしれません。
まずは、下記の追加した行のみ処理するように改造するのが、先決かと考えます。

>一度増えたデータは書き変えず、毎日追加されます。
本当に書き換えないなら、この方法が有効になります。
念のための確認ですが、以下のようなケースの場合、前日の処理をリカバリできませんがよろしいでしょうか。
①昨日、転記先に１１行～１５行までを追加し、処理をおこなった。
②但し、F列のIDが転記元に存在しないために、１１行～１５行の他の列（E列,G列,H列,I列...）にはなにも転記されなかった。
（F11,F12,F13,F14,F15のIDが転記元に存在しない）
③本日、転記先に、１６行～１８行まで追加された。
この時、F11,F12,F13,F14,F15のIDが転記元に存在するようになっていた。
既存の処理では、１１行～１５行について、転記元にIDが存在するので、11行～１５行の他の列（E列,G列,H列,I列...）に転記が行われます。
改造後の処理では、１６行～１８行しか行わないので、１１行～１５行については、一切処理されません。

上記のようになりますが、よろしいでしょうか。
それで良い場合は、作業用に１列を使用しますので、空いている列を提示してください。（仮にDA列とします）
以下の手順で追加された列のみを処理するようにします。
１．マクロ実行時、作業が終了した行（F列の最後の行）のDA列に常に1を設定します。
２．前日に、１１行から１５行まで、処理すると、DA11～DA15まで1が設定されます。
３．当日、１６行～１８行まで追加された場合、DA15まで1が設定されているので、16行から開始を行い、１８行まで処理する。
（処理が終わるとDA16～DA18に１が設定される）
４．以降同様に繰り返す。

上記でOKでしたら空いている列を提示してください。

tatsumaru77 · Answer

当方の環境で、どこで時間がかかっているかがわかるようにするために、
各処理毎の時間計測を行いました。
マクロは下記にアップしています。
https://ideone.com/zILYjq

転送元　20000行×160列
転送先　3000行×100列
のデータを処理した結果です。
イミデイトウィンドウに以下のように表示されます。
転記
Open           7.99999999999965 
GetIDs         0 
Sheet1         3.00000000000047

openは転記元の.xlsxのオープンに要した時間（単位：秒、以下同様）
GetIDsはdictの作成に要した時間
Sheet1はSheet1の設定に要した時間

ファイルのオープン時間で約８秒、Sheet1の作成で約３秒かかっていることがわかります。
あなたの環境でどこで時間がかかっているかチェックしてください。

---------------------------------------------------------
提示したマクロ中のファイルのパス名、シート名はこちらの環境に合わせてます。
    Dim t0, t1, t2, t3
で、下記時間の定義をしています。
    t0 = Time
    t1 = Time
    t2 = Time
    t3 = Time
で各処理を行った時の時間を記憶します。
（これを埋め込む位置を間違わないようにしてください）

Debug.Print "転記"
    Debug.Print "Open", 86400 * (t1 - t0)
    Debug.Print "GetIDs", 86400 * (t2 - t1)
    Debug.Print "Sheet1", 86400 * (t3 - t2)
で各処理の所要時間を表示します。

tatsumaru77 · Answer

>転送元のデータは2000行×160列で、１日に50件ほど増えます。
>転送先のデータは200行×100列でこちらは１日に5件ほど増えます。
当方、１０年ほど前のPCですが（Corei5 メモリ１２G）
転送元　20000行×160列
転送先　3000行×100列
のデータを作成し、提示されたマクロを実行すると、11秒程度でした。

あなたの環境では、どの程度の時間を使ってますか。
何秒以内が目標値なのでしょうか。また、あなたのPCのスペック（メモリサイズとCPU）は、どの程度でしょうか。

対策案としては、
①全てメモリに格納して行うようにする。（十分な実装メモリが必要）
②転送先の処理をデータが増えた行のみに限定してよいなら（毎日の増加分の５件）、そのような仕組みを作る。
（但し、今までのデータでもF列及びH列の内容が変わることがあるなら、その分の書き換える必要があるので、この方法は採用不可）
が考えられます。

tatsumaru77 · Answer

参考までにお伺いしたいのですが
１．転送元のデータ件数はおよそ何件でしょうか。
また、1日に何件ほど増えますか。
２．転送先のデータ件数はおよそ何件でしょうか。
こちらは、増えることはないのでしょうか？

Qchan1962 · Answer

>しかし、別ブックからの転記がどのようになってるのかわかりません。
#7のコードで　　sBk.Close 'ここで閉じる　までが別ブックの処理です

別ブックを開いてsBk.Worksheets("●●●")シートのA2セルから最終A列セルまでの値を初めに配列arrに入れます

その配列要素をDictionaryのキーとして登録し同時にarr要素と同じ行の値を
Itemに区切り文字を加えて登録しています

元のコード
key = sh3.Cells(row, "A")
dict(key) = sname & "|" & row

A列の値は一意のIDのような存在だと思いますので　必要なデータをすべて連想配列に登録しています
登録を終了すれば"●●●.xlsx"は不要と思われますので　閉じています

後は＃１１のコードでデータを照合して　Dictionaryにあれば
そのItemを分離してすべての処理が終わるまで格納用配列に代入して
抽出処理が終わったら、該当列に出力する流れです

処理を行わない行が含まれている場合、空白になって今うため
格納用配列をあらかじめ現状データで作る方法を取っていますが
この処理と1行ずつ処理する方法の処理時間の差はデータ無いようにもよりますしデモデータを作成していませんので分かりません。。

Qchan1962 · Answer

めぐみん_さん　そうですよね
＃６自分でも書いていたに処理に入れていませんでした　中途半端なのと
変数も使い廻しでしたので辞書を使う側を変更してみました。。

'データ加工（分岐処理）
Dim eArr As Variant, gArr As Variant
Dim mArr As Variant, oArr As Variant
Dim c As Range
Dim first_row As Long, end_row As Long
With writing_sheet
    first_row = Range("H4").End(xlDown).Row + 1
    end_row = .Cells((Rows.Count), "F").End(xlUp).Row
    eArr = .Range(.Cells(first_row, "E"), .Cells(end_row, "E")).Value
    gArr = .Range(.Cells(first_row, "G"), .Cells(end_row, "K")).Value
    mArr = .Range(.Cells(first_row, "M"), .Cells(end_row, "M")).Value
    oArr = .Range(.Cells(first_row, "O"), .Cells(end_row, "P")).Value
    n = 1
    For Each c In .Range(.Cells(first_row, "F"), .Cells(end_row, "F"))
        key2 = c.Value
'登録が無く、H列セルに値があれば処理しない
        If dict.exists(key2) = True And c.Offset(, 2) = "" Then
            Vals = Split(dict(key2), "|")
            eArr(n, 1) = Vals(0)
            gArr(n, 1) = Vals(1)
            gArr(n, 2) = Vals(2)
            gArr(n, 3) = Vals(3)
            gArr(n, 4) = Vals(4)
            gArr(n, 5) = Vals(5)
            mArr(n, 1) = Vals(6)
            oArr(n, 1) = Vals(7)
            oArr(n, 2) = Vals(8)
            n = n + 1
        Else
            n = n + 1
        End If
    Next
'データ　出力
    Application.ScreenUpdating = False
    .Cells(first_row, "E").Resize(UBound(eArr)).Value = eArr
    .Cells(first_row, "G").Resize(UBound(gArr), UBound(gArr, 2)).Value = gArr
    .Cells(first_row, "M").Resize(UBound(mArr)).Value = mArr
    .Cells(first_row, "O").Resize(UBound(oArr), UBound(oArr, 2)).Value = oArr
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

めぐみん_ · Answer

日々増えても必ず最初の行から処理をしなきゃいけない？

VBA 別ブックからの転記の高速化について VBA 別ブックからの転記の高速化についてご教授下さい。

No17でアップしたソースに誤りがありましたのでお詫びして訂正します。

>「dict(key) = row1 - 2 + 1」のところがわかりません、もしよかったら教えて頂けませんか？

>データの内容は変更しませんが、データ自体が増える事はあるので、こちらの方法は難しそうです。

補足ありがとうございました。

当方の環境で、どこで時間がかかっているかがわかるようにするために、

>転送元のデータは2000行×160列で、１日に50件ほど増えます。

参考までにお伺いしたいのですが

>しかし、別ブックからの転記がどのようになってるのかわかりません。

めぐみん_さん そうですよね

日々増えても必ず最初の行から処理をしなきゃいけない？

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

このQ&Aを見た人はこんなQ&Aも見ています

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

このQ&Aを見た人がよく見るQ&A

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

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

めぐみん_さん　そうですよね