「教えて!ピックアップ」リリース!

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

A 回答 (19件中1~10件)

>「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)をクリックすると表示されます。
「VBA 別ブックからの転記の高速化につい」の回答画像18
    • good
    • 0

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


こちらに変えてください。失礼しました。
https://ideone.com/BFxAls

変更箇所は、
68,69行の
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
です。
Application.Calculation = xlCalculationAutomaticがないと
excelが手動計算のままになってしまいます。
    • good
    • 0
この回答へのお礼

修正個所、ありがとうございます!
イミデイトウィンドウのところですが、会社のPCなんできっちりとは覚えてないですが、

Open 0.8.........
GetIDs 0
Sheet1 0
くらいでした。
解説もしていただき、本当にありがとうございます!!

お礼日時:2022/07/30 10:01

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

すみません、、、。

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

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

ありがとうございます!速くなりました!!結局、コードをまるまる作って頂くかたちになってしまいすみません!今、コードをきちんと理解する為に解読していますが、39行目の「dict(key) = row1 - 2 + 1」のところがわかりません、もしよかったら教えて頂けませんか?

お礼日時:2022/07/29 19:32

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


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

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

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

上記でOKでしたら空いている列を提示してください。
    • good
    • 0
この回答へのお礼

色々考えてくださり、本当にありがとうございます!
提示してくださった確認内容ですが、昨日なかったデータが今日入っているということはあります。データの内容は変更しませんが、データ自体が増える事はあるので、こちらの方法は難しそうです。すみません、、、。

お礼日時:2022/07/28 14:01

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


各処理毎の時間計測を行いました。
マクロは下記にアップしています。
https://ideone.com/zILYjq


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

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

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

---------------------------------------------------------
提示したマクロ中のファイルのパス名、シート名はこちらの環境に合わせてます。
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)
で各処理の所要時間を表示します。
    • good
    • 0

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


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

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

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

デモを作って試してくださり、本当にありがとうございます!!!pcは会社のなので詳しくは分かりません。実行してかかる時間は長いとおそらく2.3分かかっていると思います。
転送先のデータの増える数は平均して50件程です。一度増えたデータは書き変えず、毎日追加されます。

お礼日時:2022/07/27 22:59

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


1.転送元のデータ件数はおよそ何件でしょうか。
また、1日に何件ほど増えますか。
2.転送先のデータ件数はおよそ何件でしょうか。
こちらは、増えることはないのでしょうか?
    • good
    • 0
この回答へのお礼

諦めずにお付き合い頂きありがとうございます。
転送元のデータは2000行×160列で、1日に50件ほど増えます。
転送先のデータは200行×100列でこちらは1日に5件ほど増えます。

お礼日時:2022/07/27 16:54

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


#7のコードで  sBk.Close 'ここで閉じる までが別ブックの処理です

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

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

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

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

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

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

ありがとうございます!今一度組み立ててみてますが、なかなか苦戦中です、、。

お礼日時:2022/07/27 23:01

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


#6自分でも書いていたに処理に入れていませんでした 中途半端なのと
変数も使い廻しでしたので辞書を使う側を変更してみました。。

'データ加工(分岐処理)
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
    • good
    • 1
この回答へのお礼

細かく、ありがとございます!
なんとなく教えていただいたコードは理解できたように思います。
しかし、別ブックからの転記がどのようになってるのかわかりません。dictionayは使わない方法ですか?ちょっと混乱中です、、、。

お礼日時:2022/07/27 10:32

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

    • good
    • 1
この回答へのお礼

ありがとうございます!
いいえ、増えたところから処理したいです。しかし、その方法が、分からず、、、。

お礼日時:2022/07/27 08:58

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

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


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

人気Q&Aランキング