VBAで複数Excelの複数条件を満たすもの抽出
2つのExcelファイル("1月顧客別商品別.xls"と"顧客別管理.xlsx")において、顧客コードと商品コードの双方が一致しているものの売上高と粗利を顧客別管理.xlsxの対応欄(商品別になっている)(1月の売上高の入力欄:K9~K32、粗利の入力欄:K39~62)に入力させるVBAを作りたく、以下のコードを書いたのですが、コードが恐らくハチャメチャのため重たすぎて正しく動作しているかどうかわかりません。
大量のデータがあるためDictionaryを使用したものの、どん詰まりすぎてもう何もわかりません…
間違っているなら修正ポイントを、正しいなら軽量化する方法を教えていただけると大変助かります。
なお、前提条件として、
"1月顧客別商品別.xls":”集計”シートのA~E列に”顧客コード”、”顧客名”、”商品コード”、”売上高”、”粗利”が2行目以降並んでいます。
"顧客別管理.xlsx":左から4枚目~最後から数えて3ページ目までのシートがそれぞれ顧客別のシートで、それぞれシート名が顧客コードになっていて、B列に売上高の商品一覧(B9~B32)・粗利の商品一覧(B39~B62)が並んでおり、検索しやすくなるためにそれぞれ対応する行のA列に商品コードを入力してあります。
-----------------------------------------------------------------------------------------
Sub 最終集計シートと月次実績シートの顧客名項目名一致入力()
Dim nws As Worksheet, mws As Worksheet, ynws As Worksheet, ydws As Worksheet
Dim mdwb As Workbook, ydwb As Workbook
Dim i
Dim Dic As Object
Dim dkey As Variant, data As Variant
Dim dtRow As Integer
Dim opRow As Long
Set mdwb = Workbooks("1月顧客別商品別.xls")
Set ydwb = Workbooks("顧客別管理.xlsx")
Set mws = mdwb.Worksheets("集計")
Set Dic = CreateObject("Scripting.Dictionary")
mdwb.Activate
mws.Activate
dtRow = Cells(Rows.Count, 1).End(xlUp).Row
dtRow = 2 '月次実績データ行設定
'C列をDictionaryオブジェクトに格納
Do Until mws.Cells(dtRow, 3).Value = ""
dkey = mws.Cells(dtRow, 3).Value
data = Array(mws.Cells(dtRow, 4), mws.Cells(dtRow, 5))
If Not Dic.exists(dkey) Then
Dic.Add dkey, Null
End If
dtRow = dtRow + 1
Loop
ydwb.Activate
For i = 4 To ydwb.Worksheets.Count - 2
Set ydws = ydwb.Worksheets(i)
ydws.Activate
opRow = 9
Do Until ydws.Cells(opRow, 1).Value = 32
dkey = ydws.Cells(opRow, 1).Value
If Dic.exists(dkey) And mws.Cells(dtRow, 1) = ydws.Name Then
ydws.Cells(opRow, 11).Value = data(0)
ydws.Cells(opRow + 30, 11).Value = data(1)
End If
Loop
Next i
End Sub