Exceldで、ブックから別ブックの行と列の交わった条件へ転記するVBAコードをご教授願います

Excelにて、ブックから別ブックの行と列の交わった条件へ転記する際のVBAコードが分かりませんどうかご教授願います。

＜詳細＞
転記先のシートが、2シートから5シートヘとなり3シート追加され、現在のVBAコードの何処をどのように追加して良いのか分からず困っています。

・転記元　ブック名⇒サンプル転記4.xism　　シート名⇒データーリスト
・転記先　ブック名⇒PB.xls　　シート名⇒Aと B の二つのシートプラス　C工程,D工程,E工程の3つのシートが追加となりました。
　（セルには空欄あり）

転記元の基本データー表（サンプル転記4.xism）シート名（データーリスト）Ｄ列の部品番号と、別ブック（PB.xls）の、各シートのA列の部品番号と合致して、尚且つ　１行目の日付（1～31）と交差したところへ（データーリスト）F列の数量転記したい。※ 日付はH列(8列目)以降に有るとしています。

今回追加となった3つのシートを含め、５つのシートを検索し合致データーを探す。(空セル有り）

※添付写真の上が、サンプル転記4.xism　　シート名⇒データーリスト
※添付写真下が、PB.xls　　シート名⇒A,B,C工程,D工程,E工程
添付写真から例えば、日付が1日で、C43R010　の部品番号があり、（データーリスト）Ｄ列の部品番号と、別ブック（PB.xls）の、各シートのA列の部品番号と合致して、尚且つ、（PB.xls）の１行目の日付（1～31）と交差したところへ（データーリスト）F列の数量転記したい。



説明がうまくありませんが、お分かりになる方、ご教授のほどよろしくお願いします。


Sub Sample()

Dim A列 As Long
Dim B列 As Long
Dim 行 As Long
Dim 位置 As Long
Dim 終 As Long
Dim A辞書 As New Dictionary
Dim B辞書 As New Dictionary
Dim D辞書 As New Dictionary
　Workbooks.Open Filename:=ThisWorkbook.Path & "\PB.xls"
　Sheets("A").Select
　For A列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, A列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If A辞書.Exists(Cells(行, 1).Value) = False Then
　　　A辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Sheets("B").Select
　For B列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, B列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If B辞書.Exists(Cells(行, 1).Value) = False Then
　　　B辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Windows("サンプル転記4.xlsm").Activate
　Sheets("データーリスト").Select
　For 行 = 3 To Cells(Rows.Count, 4).End(xlUp).Row
　　If D辞書.Exists(Cells(行, 4).Value) = False Then
　　　D辞書.Add Cells(行, 4).Value, Cells(行, 6).Value
　　　位置 = 位置 + 1
　　End If
　Next
　終 = 位置 - 1
　Windows("PB.xls").Activate
　For 位置 = 0 To 終
　　If A辞書.Exists(D辞書.Keys(位置)) Then
　　　Sheets("A").Cells(A辞書.Item(D辞書.Keys(位置)), A列).Value = D辞書.Items(位置)
　　End If
　　If B辞書.Exists(D辞書.Keys(位置)) Then
　　　Sheets("B").Cells(B辞書.Item(D辞書.Keys(位置)), B列).Value = D辞書.Items(位置)
　　End If
　Next
　MsgBox ("終了しました")

End Sub

No.1 ベストアンサー 回答者： GooUserラック 回答日時： 2020/02/09 05:54

良く見たわけではありませんが、今まで普通に動いていたならば以下のように追加するだけで動くような気がします。

Sub Sample()

Dim A列 As Long
Dim B列 As Long
Dim C列 As Long
Dim D列 As Long
Dim E列 As Long
Dim 行 As Long
Dim 位置 As Long
Dim 終 As Long
Dim A辞書 As New Dictionary
Dim B辞書 As New Dictionary
Dim C辞書 As New Dictionary
Dim D辞書 As New Dictionary
Dim E辞書 As New Dictionary
Dim 元辞書 As New Dictionary
　Workbooks.Open Filename:=ThisWorkbook.Path & "\PB.xls"
　Sheets("A").Select
　For A列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, A列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If A辞書.Exists(Cells(行, 1).Value) = False Then
　　　A辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Sheets("B").Select
　For B列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, B列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If B辞書.Exists(Cells(行, 1).Value) = False Then
　　　B辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Sheets("C工程").Select
　For C列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, C列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If C辞書.Exists(Cells(行, 1).Value) = False Then
　　　C辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Sheets("D工程").Select
　For D列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, D列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If D辞書.Exists(Cells(行, 1).Value) = False Then
　　　D辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Sheets("E工程").Select
　For E列 = 8 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, E列).Value = Day(Date) Then Exit For
　Next
　For 行 = 3 To Cells(Rows.Count, 1).End(xlUp).Row
　　If E辞書.Exists(Cells(行, 1).Value) = False Then
　　　E辞書.Add Cells(行, 1).Value, 行
　　End If
　Next
　Windows("サンプル転記4.xlsm").Activate
　Sheets("データーリスト").Select
　For 行 = 3 To Cells(Rows.Count, 4).End(xlUp).Row
　　If 元辞書.Exists(Cells(行, 4).Value) = False Then
　　　元辞書.Add Cells(行, 4).Value, Cells(行, 6).Value
　　　位置 = 位置 + 1
　　End If
　Next
　終 = 位置 - 1
　Windows("PB.xls").Activate
　For 位置 = 0 To 終
　　If A辞書.Exists(元辞書.Keys(位置)) Then
　　　Sheets("A").Cells(A辞書.Item(元辞書.Keys(位置)), A列).Value = 元辞書.Items(位置)
　　End If
　　If B辞書.Exists(元辞書.Keys(位置)) Then
　　　Sheets("B").Cells(B辞書.Item(元辞書.Keys(位置)), B列).Value = 元辞書.Items(位置)
　　End If
　　If C辞書.Exists(元辞書.Keys(位置)) Then
　　　Sheets("C工程").Cells(C辞書.Item(元辞書.Keys(位置)), C列).Value = 元辞書.Items(位置)
　　End If
　　If D辞書.Exists(元辞書.Keys(位置)) Then
　　　Sheets("D工程").Cells(D辞書.Item(元辞書.Keys(位置)), D列).Value = 元辞書.Items(位置)
　　End If
　　If E辞書.Exists(元辞書.Keys(位置)) Then
　　　Sheets("E工程").Cells(E辞書.Item(元辞書.Keys(位置)), E列).Value = 元辞書.Items(位置)
　　End If
　Next
　MsgBox ("終了しました")

End Sub

この回答へのお礼

いつも大変お世話になっております。
上手くいきました。
対応ありがとうございます。
本当に感謝しております。

お礼日時：2020/02/09 06:22