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

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

質問者からの補足コメント

• 皆さま、早速のご回答ありがとうございます。
  ご指摘にありましたシート名ですが、転記元シートから転記先シートに移す感じです。画像は、スマホからなので貼り付け出来ませんが、、、すみません。
  転記先シートのF列に番号を入力→マクロ実行→転記元シートから同じ番号の各情報を転記といった動きです。転記元シートと転記先シートは別のExcelブックに、なります。
  前までは関数でしていたのですが、こちらも時間がかかるのと、関数を入れているセルに上書き等多発して、VBAで、と言うことになりました。また、転記元シートの並びは固定で変えられません。

    補足日時：2022/07/26 19:26

• tatsumaru77さんの質問にありましたPCスペックですが、corei3の4Gでした。

    補足日時：2022/07/28 08:58

• 補足で、皆様へのお礼となってしまい、すみません！
  皆さんが、教えてくださった事はどれも本当に勉強になりました！ベスとアンサーを決めるのが心苦しいくらい、、、、。
  見捨てずに教えて下さり、本当にありがとうございました！！！

    補足日時：2022/07/30 12:06

No.9 回答者： Qchan1962 回答日時： 2022/07/26 20:46

連投すみません

風呂で考えてすぐ良さそうな方法が浮かんだので書いて置きます
F列が基準として
'データ加工（分岐処理）以下のコードです
あらかじめ配列を作る方法です・・速度は分かりません（未検証）
'データ加工（分岐処理）
Dim eArr As Variant, gArr As Variant
Dim mArr As Variant, oArr As Variant
Dim c As Range
With writing_sheet
n = .Cells((Rows.Count), "F").End(xlUp).row
eArr = .Range(.Cells(4, "E"), .Cells(n, "E")).Value
gArr = .Range(.Cells(4, "G"), .Cells(n, "K")).Value
mArr = .Range(.Cells(4, "M"), .Cells(n, "M")).Value
oArr = .Range(.Cells(4, "O"), .Cells(n, "P")).Value
n = 1
For Each c In .Range(.Cells(4, "F"), .Cells(.Rows.Count, "F").End(xlUp))
key2 = c.Value
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(4, "E").Resize(UBound(eArr)).Value = eArr
.Cells(4, "G").Resize(UBound(gArr), UBound(gArr, 2)).Value = gArr
.Cells(4, "M").Resize(UBound(mArr)).Value = mArr
.Cells(4, "O").Resize(UBound(oArr), UBound(oArr, 2)).Value = oArr
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

もっと良い方法があるような気がする・・・

No.8 回答者： Qchan1962 回答日時： 2022/07/26 19:40

＃6＆＃７　です

＃７のコード　ストップ！ストップです　すみません

Else
'sh3.Cells(row, "E").Value = ""　・・・・コメントにしてある。。
消してはいけないのですね・・・消えてしまいます・・・
Else
ここにデータを既存データを取得するコードが必要
n = n + 1


あと　コードミスの訂正
eArrとmArrは一次元配列なので
下記の様に訂正してください

'データ　出力
.Cells(4, "E").Resize(UBound(eArr) + 1).Value = Application.Transpose(eArr)
.Cells(4, "G").Resize(UBound(gArr) + 1, UBound(gArr, 2) + 1).Value = gArr
.Cells(4, "M").Resize(UBound(mArr) + 1).Value = Application.Transpose(mArr)
.Cells(4, "O").Resize(UBound(oArr) + 1, 2).Value = oArr
End With

ちょっと時間が無いので・・自身で良い方法考え付きますか？

この回答へのお礼

ご丁寧にありがとうございます！皆さんに教えていただいた事を、順に頭の中で整理中です、、、。

お礼日時：2022/07/26 20:38

No.7 回答者： Qchan1962 回答日時： 2022/07/26 19:18

サンプル処理コード

Const Scrbook As String = "●●●.xlsx"
Const Folder As String = "○○○"
Public Sub sample()
Dim dict As Object
Dim key2 As Variant
Dim Vals As Variant
Dim i As Long, n As Long
Dim thisBK As Workbook, writing_sheet As Worksheet
Dim sBk As Workbook, sh_sname As Worksheet
'実行ブック実行シートを先に登録
Set thisBK = ActiveWorkbook
Set writing_sheet = thisBK.Worksheets("Sheet1")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'データを開く（データ取得
Workbooks.Open Filename:=Folder & "\" & Scrbook, ReadOnly:=True, UpdateLinks:=0
'開いたブック、シートを登録・・今回あまり必要ないか
Set sBk = ActiveWorkbook
Set sh_sname = sBk.Worksheets("●●●")
'Dictionaryに必要データを全て登録（ごめんね実行時バインディングです。メソッド、プロパティはありきたりなので
Set dict = CreateObject("Scripting.Dictionary")
Dim arr As Variant
With sh_sname
arr = Application.Transpose(.Range(.Cells(2, 1), .Cells(Rows.Count, "A").End(xlUp)))
For i = LBound(arr) To UBound(arr) 'LBound(arr)は1
n = i + 1 '2行から始まるので調整
If Not dict.exists(arr(i)) Then
dict.Add arr(i), .Cells(n, "C").Value & "|" & .Cells(n, "Z").Value & "|" & .Cells(n, "H").Value _
& "|" & .Cells(n, "G").Value & "|" & .Cells(n, "L").Value & "|" & .Cells(n, "K").Value _
& "|" & .Cells(n, "DQ").Value & "|" & .Cells(n, "T").Value & "|" & .Cells(n, "V").Value
End If
Next i
End With
sBk.Close 'ここで閉じる
'データ加工（分岐処理）
Dim eArr, gArr, mArr, oArr
Dim Rng As Range, c As Range
With writing_sheet
Set Rng = .Range(.Cells(4, "F"), .Cells((Rows.Count), "F").End(xlUp))
n = Rng.Count - 1
ReDim eArr(n), gArr(n, 4), mArr(n), oArr(n, 1)
n = 0
For Each c In Rng
key2 = c.Value
If dict.exists(key2) = True And c.Offset(, 2) = "" Then
Vals = Split(dict(key2), "|")
eArr(n) = Vals(0)
gArr(n, 0) = Vals(1)
gArr(n, 1) = Vals(2)
gArr(n, 2) = Vals(3)
gArr(n, 3) = Vals(4)
gArr(n, 4) = Vals(5)
mArr(n) = Vals(6)
oArr(n, 0) = Vals(7)
oArr(n, 1) = Vals(8)
n = n + 1
Else
n = n + 1
End If
Next
'データ　出力
.Cells(4, "E").Resize(UBound(eArr) + 1).Value = eArr
.Cells(4, "G").Resize(UBound(gArr) + 1, UBound(gArr, 2) + 1).Value = gArr
.Cells(4, "M").Resize(UBound(mArr) + 1).Value = mArr
.Cells(4, "O").Resize(UBound(oArr) + 1, 2).Value = oArr
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

No.6 回答者： Qchan1962 回答日時： 2022/07/26 19:12

こんばんは、

複雑（面倒な）なシートフォーマットを処理されているようで察します
ここまでくると初めから直すのは中々難しいでしょうか？
書き込み部分に処理時間を要しているのは分かると思います
コードを拝見するといくつか疑問があります
dict(key) = sname & "|" & row　区切り文字でつなげる　処理方法をご存知なのに　なぜ　行numberで終わらせてしまうのでしょうか？
必要とする各列の値を区切り文字でつなげ入れてしまえば良いのに・・と思うのは私だけかな？
あと、毎回2行目、4行目より下を処理しなくては成らないのでしょうか？
照合するデータ●●●.xlsxは分かりますが・・
Worksheets("Sheet1")は毎回上からなのでしょうか？
F列の新しいところだけ　とか　出来ないものでしょうかね・・
逆に●●●.xlsxの方が変わるのかな・・・と言っても仕方ないので
お示しのコードに戻りますが
コードを読みながら　処理を分け　書き直してみました
デモデータが無いので　未検証です。
処理があっているか判らないのと　処理速度が向上するかもわかりませんが
エラー生の可能性がある個所がいくつか有りますが、元のコードにもないので書いていません。

文字数オーバー？受け付けてくれないので2度に分けます

No.5 回答者： fujillin 回答日時： 2022/07/26 16:28

No3です。

シートの構成やデータ件数、使用方法などがまったくわからないので、記述しませんでしたが、根本的に速度アップを目指すのなら・・

1）シート構成や、データ順などを処理しやすい形式にする。
ことが考えられます。
処理を単純化できれば、当然ながら速度も向上します。

2）計算処理を関数等に利用する。
関数が速いわけではありませんけれど。
入力（？）データがどのような形で入力されるのかわからないので何とも言えませんが、例えば手入力であるならば、関数計算でも十分な速さがあると思いますので、入力終了時には同時に転記も終わっていることが期待できます。
（マクロを実行する手間も不要になります）

あるいは、一部だけ利用するとして、ID(?)検索だけは関数で行うなども考えられます。
転記にはマクロを利用するにしても、これによって検索のためのDictionayを作成しなくても良くなりますし、処理自体も単純化できるはずと思います。


※ シート構成や使い方にも関係しているので、即座には反映できない部分も多いと想像しますけれど、「速くしたい」というご希望なので、ご参考までに。

No.4 回答者： KenKen_SP 回答日時： 2022/07/26 14:54

こんにちは。

ソース読み解いてないですけど、セルへのアクセスが冗長ですね、、ここで時間がかかっているので、それを極力減らす工夫が必要かと思います。

その他の観点から。

CPU,メモリが強力な今となってはあまり関係ないかもですが、サブプロシージャへ文字列やオブジェクトを引数で渡すなら ByVal ではなく、ByRef キーワードになります。

ByVal は簡単に言うとメモリ上で文字列等を複製し、それを渡しますのでメモリ消費、時間ロスになってます。メモリ上で同じ内容が２箇所に存在する格好ですから、極端に例えると 100MB の文字列を ByVal で渡すのはどういう事か想像できますよね。

→渡した先で加工しないのなら ByRef の方が良いかな。

Dictionay の必要性は・・・？
今回は無いかもしれませんが、関連 Tips として CreateObject はレイトバインドといいますが、参照設定のアーリーバインドより処理速度はわずかに低下してます。
少しでも処理速度をあげたり、コーディングの手間軽減（特に初心者はインテリセンス（コード補完））のためアーリーバインドすべきです。

なぜか、教えてGooではレイトバインドの例しか見ないですが。
Dictionary に読み込むときも

For i = 1 to 10000
　　IF dic.Exists(Cells(i, 1).Value) Then
　　　　追加処理
　　End IF
Next

とするより、

Dim buf As Variant
buf = Range("A1:A10000").Value
For i = 1 to 10000
　　IF dic.Exists(buf(i,1)) Then
　　　　追加処理
　　End IF
Next

として配列に読み込んでから、その２次元配列をループさせた方が高速です。このようにセルへのアクセスを極力減らすのが高速化のポイントでしょう。

この回答へのお礼

ご丁寧な返答ありがとうございます。やはりセルへのアクセスが重い感じですよね、、、。教えていただいた事をためしてみようと思います。

お礼日時：2022/07/26 20:44

No.3 回答者： fujillin 回答日時： 2022/07/26 14:22

こんにちは

コードのみのご提示なので、内容を読み解くのは面倒なので、以下は方法論のみです。

速度を上げるための
　・ScreenUpdating = False
　・Calculation = xlCalculationManual
などはすでに行っているようですので、あとはセルへのアクセス（読み書き）の回数を減らすことが一番効果的な手段となると思います。
セル範囲をまとめて読み書きすることで、速度はかなり向上できるはずです。
（ただし、その分メモリを使います）

また、速度向上には大きくは関係しませんけれど、Dictionaryオブジェクトで、わざわざ文字連結を行っているようですが、
　＞dict(key) = sname & "|" & row
snameは引数で渡されている値で一律なので、記録する必要もなく、 row だけを記録するようにすればすむものと思います。
それによって、
　＞Vals = Split(dict(key2), "|")
　＞sname = Vals(0)
　＞row2 = Vals(1)
と分解する処理もなくなるでしょう。
（わずかながらですが、速くなる方向ではあります）
（Vals(0)はメイン側で与えた引数なので、値はわかっているはず）


さて、セルへのアクセスを減らす具体的な方法ですが、例えばDictionary作成時に順に各セルへアクセスしていますが、これをまとめてアクセスすれば1回ですみます。
通常は登録時にも
　dict.exists(key)
で存在を確認しながら登録するものと思いますが、ご提示のコードはそうなってはいません。
それでも良いものと仮定して、常に上書きするのなら、
　v = sh3.Cells(2, 1).Resize(maxrow - 1).Value
　For row = LBound(v) To UBound(v)
　　dic(v(row, 1)) = row + 1
　Next row
などとすることで、セルへのアクセスは1回で済ませられます。
（ついでながら、一般的なプロパティである「Row」をそのまま変数名として使用するのは避けておいた方が宜しいと思います）

※ なお、セル範囲の値を読み込む場合は、変数はVariantの必要があります。
また、必ず2次元配列になりますので、扱う際にはそのつもりで扱ってください。

シートの転記に際しても、個々にアクセスするのではなく（セル範囲が飛び飛びなのでちょっと面倒ですが）、一旦、変数に読み込んでメモリ上で修正し、まとめて書き込むような方法にすれば、アクセスは2回で済みます。
ただし、対象範囲の書き換えないセルに関数が設定されている場合には、値で上書きしてしまうため、この方法は使えません。

例えば、
　v = sh3.Cells(row3, 5).Resize(, 12).Value
とすれば、 row3 行目のE:P列迄をまとめて読み込めますので、これを修正した後
　sh3.Cells(row3, 5).Resize(, 12).Value = v
のようにまとめて書き込むといった塩梅です。
転記元シートへのアクセスも同様ですね。
ただ、さらに飛び飛びになっているようですので、DQ列だけは単独アクセスでも良いのかも知れません。

この回答へのお礼

粗末な質問内容にも関わらず、こんなにも読み解いて頂きありがとうございます！

お礼日時：2022/07/26 20:40

No.2 回答者： めぐみん_ 回答日時： 2022/07/26 13:48

発熱でボケてる自信はありますが。

Scripting.Dictionaryを使ってる利点が見られないかな。
結局セル同士での代入ですし。

前回の質問のリンクはあった方が良い。

この回答へのお礼

ご体調大丈夫でしょうか？大変な時にも関わらず、ご回答頂きありがとうございます！
初心者すぎてScripting.Dictionaryが不要との事に、驚きました、、、。

お礼日時：2022/07/26 20:42

No.1 回答者： tatsumaru77 回答日時： 2022/07/26 13:24

以下の情報が不足しています。

それらを提示すると、良い回答が得られやすくなるかと。

転記元のブック名、及びシート名
転記先のブック名、及びシート名
転記元シートのレイアウト（各セルの位置がわかる画像）
転記先シートのレイアウト（各セルの位置がわかる画像）
どのように転記元から転記先へ転記したいのか、転記の具体的な方法