VBA 別ブックから条件に合うものを転記したいです

上の表を埋めるため、別ブックの下の表から条件に合うセルを転記し、また、空白のセルに[x]を入れたいです。
東京-りんご　セルB2に入るのはa(B4)
　　　　　　　セルC2、D2はx

VBA初心者の為、なかなか上手く行かず、、、
ご教授よろしくお願いします。

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

• 情報足らずですみません。
  補足いたします。
  ①マクロは上の表のブックに格納したいです
  ②一覧まとめ
  ③sheet1
  ④各県くだもの
  ⑤下の表は閉じた状態でオープンするところから始めたいと思っています。
  フォルダ名:各県まとめフォルダ
  上、下の表どちらも同じフォルダに格納してあります。
  ⑥⑦どちらも追加するケースはありません。

  No.1の回答に寄せられた補足コメントです。 補足日時：2024/02/26 06:46

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/02/26 09:38

以下のマクロを標準モジュールに登録してください。

Option Explicit

Public Sub 一覧まとめ()
Dim ws1 As Worksheet
Dim wb2 As Workbook
Dim ws2 As Worksheet
Dim maxrow1 As Long
Dim maxcol1 As Long
Dim maxcol2 As Long
Dim row1 As Long
Dim col1 As Long
Dim col2 As Long
Dim dicT As Object '地区用
Dim dicK As Object '果物用
Dim nameT As String '地区名
Dim nameK As String '果物名
Dim fpath As String
Set dicT = CreateObject("Scripting.Dictionary")
Set dicK = CreateObject("Scripting.Dictionary")
Set ws1 = ThisWorkbook.Worksheets("一覧まとめ")
maxrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row '1列目の最終行を求める
maxcol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column '1行目の最終列を求める
If maxrow1 < 2 Then Exit Sub
If maxcol1 < 2 Then Exit Sub
ws1.Range(ws1.Cells(2, 2), ws1.Cells(maxrow1, maxcol1)).ClearContents
'各地区の行番号を記憶
For row1 = 2 To maxrow1
nameT = ws1.Cells(row1, 1).Value
dicT(nameT) = row1
Next
'各果物の列番号を記憶
For col1 = 2 To maxcol1
nameK = ws1.Cells(1, col1).Value
dicK(nameK) = col1
Next
'各県くだもの.xlsxをオープン
fpath = ThisWorkbook.Path & "\" & "各県くだもの.xlsx"
Set wb2 = Workbooks.Open(fpath)
Set ws2 = wb2.Worksheets("Sheet1")
maxcol2 = ws2.Cells(3, Columns.Count).End(xlToLeft).Column '3行目の最終列を求める
nameK = "未定"
'全地区分繰り返す
For col2 = 2 To maxcol2
If ws2.Cells(2, col2).Value <> "" Then
nameK = ws2.Cells(2, col2).Value
End If
nameT = ws2.Cells(3, col2).Value
If dicK.exists(nameK) = False Then
MsgBox (nameK & "：この果物は一覧まとめにありません")
Exit Sub
End If
If dicT.exists(nameT) = False Then
MsgBox (nameT & "：この地区は一覧まとめにありません")
Exit Sub
End If
row1 = dicT(nameT)
col1 = dicK(nameK)
ws1.Cells(row1, col1).Value = ws2.Cells(4, col2).Value
Next
wb2.Close
MsgBox ("完了")
End Sub

この回答へのお礼

ご回答ありがとうございました。
回答頂いたマクロで試したところ、やりたかった事ができました。
私にはマクロの内容は難しく、まだわからない所もありますが、コピペするくらいしか思いつかなかったので、このような方法もあるんだと大変勉強になりました。
これからも度々質問させていただくと思うので、機会がありましたらよろしくお願い致します。

お礼日時：2024/02/26 22:18

No.3 回答者： tatsumaru77 回答日時： 2024/02/26 09:44

No2です。

各くだものの照合は、果物名が完全に一致するかどうかで見ています。
一覧まとめに「バナナ」があり、Sheet1に「ばなな」があった場合はエラーになります。
果物名は、提示された例でなくても構いません。
（パパイヤ、マンゴー等があっても処理可能です）
果物の追加（列の追加）も可能です。

各地区についても同様です。
地区の追加も可能です。

No.1 回答者： tatsumaru77 回答日時： 2024/02/25 23:18

不明点です。

①マクロは、上の表のあるブックに格納すると考えて良いでしょうか。
②上の表のシート名はなんでしょうか。
③下の表のシート名はなんでしょうか。
④下の表のシートを格納したブックのブック名は何でしょうか。
⑤上記④のブックは、マクロ実行時、すでにオープンされている前提で良いですか。
それとも、クローズされていて、オープンするところから始めるのでしょうか。
そうであれば、そのブックを格納したフォルダ名も提示する必要があります。
⑥上記の表の行と列が追加されることはないと考えて良いですか。
果物で、メロン、パパイヤが追加されるようなケース
地名で、青森、新潟が追加されるようなケース。
⑦上記の⑥と同じように、地名、果物の種類が追加されるケースはないと考えて良いですか。