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 · Answer

以下の情報が不足しています。
それらを提示すると、良い回答が得られやすくなるかと。

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

めぐみん_ · Answer

発熱でボケてる自信はありますが。
Scripting.Dictionaryを使ってる利点が見られないかな。
結局セル同士での代入ですし。

前回の質問のリンクはあった方が良い。

fujillin · Answer

こんにちは

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

速度を上げるための
　・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列だけは単独アクセスでも良いのかも知れません。

KenKen_SP · Answer

こんにちは。

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

その他の観点から。

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

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

fujillin · Answer

No3です。

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

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

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

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

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

Qchan1962 · Answer

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

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

Qchan1962 · Answer

サンプル処理コード
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

Qchan1962 · Answer

＃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

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

Qchan1962 · Answer

連投すみません
風呂で考えてすぐ良さそうな方法が浮かんだので書いて置きます
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

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

めぐみん_ · Answer

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

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

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

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

こんにちは

こんにちは。

No3です。

こんばんは、

サンプル処理コード

＃6＆＃７ です

連投すみません

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

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

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

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

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

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

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

＃6＆＃７　です