Option Explicit
 
Dim dicT As Object
Dim sh1 As Worksheet
 
Public Sub D列の値を設定()
    Dim maxrow As Long
    Dim wrow As Long
    Set dicT = CreateObject("Scripting.Dictionary")
    Set sh1 = Worksheets("Sheet1")
    maxrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    'B列の数字を記憶
    For wrow = 1 To maxrow
        dicT(sh1.Cells(wrow, "B").Value) = wrow
    Next
    Call set_Dval("Sheet2")
    Call set_Dval("Sheet3")
End Sub
Private Sub set_Dval(ByVal wsname As String)
    Dim ws As Worksheet
    Dim maxrow As Long
    Dim maxcol As Long
    Dim wrow As Long
    Dim wcol As Long
    Dim val As Variant
    Dim val2 As String
    Dim row1 As Long
    Dim set_count As Long
    Dim skip_count As Long
    set_count = 0
    skip_count = 0
    Set ws = Worksheets(wsname)
    maxrow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
    maxcol = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
    For wrow = 1 To maxrow
        For wcol = 1 To maxcol
            val = ws.Cells(wrow, wcol)
            If val <> "" And dicT.exists(val) = True Then
                val2 = ws.Cells(wrow + 1, wcol).Value
                If val2 <> "" And ws.Cells(wrow + 1, wcol).MergeCells = True Then
                    row1 = dicT(val)
                    If sh1.Cells(row1, "C").Value = val2 Then
                        ws.Cells(wrow, wcol + 1).Value = sh1.Cells(row1, "D").Value
                        set_count = set_count + 1
                    Else
                        skip_count = skip_count + 1
                        Debug.Print wsname, "行=" & wrow, "列=" & wcol
                    End If
                End If
            End If
        Next
    Next
    MsgBox (wsname & "設定完了 設定件数=" & set_count & " スキップ件数=" & skip_count)
End Sub