Option Explicit
Public Sub 品名別集計()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim dicH As Object
    Dim dicD As Object
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim maxcol1 As Long
    Dim maxcol2 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim col1 As Long
    Dim col2 As Long
    Dim keyc As String
    Dim keyr As String
 
    Set dicH = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicD = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set sh1 = Worksheets("sheet1")
    Set sh2 = Worksheets("sheet2")
    maxrow1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row 'sheet1 最終行を求める
    maxrow2 = sh2.Cells(Rows.Count, "B").End(xlUp).Row 'sheet2 最終行を求める
    maxcol1 = sh1.Cells(4, Columns.Count).End(xlToLeft).Column   'Sheet1 最終列を求める
    maxcol2 = sh2.Cells(2, Columns.Count).End(xlToLeft).Column   'Sheet2 最終列を求める
    If maxrow1 < 5 Then Exit Sub
    If maxrow2 < 2 Then Exit Sub
    If maxcol1 < 3 Then Exit Sub
    If maxcol2 < 3 Then Exit Sub
    For col2 = 3 To maxcol2
        keyc = sh2.Cells(2, col2).Value
        dicH(keyc) = col2
    Next
    For row2 = 3 To maxrow2
        keyr = sh2.Cells(row2, "B").Value
        dicD(keyr) = row2
    Next
    For col1 = 3 To maxcol1
        keyc = sh1.Cells(2, col1).Value
        If keyc <> "" Then
            If dicH.exists(keyc) = False Then
                MsgBox (keyc & "はSheet2に存在しません")
                sh1.Activate
                sh1.Cells(2, col1).Select
                Exit Sub
            End If
        End If
    Next
    For row1 = 5 To maxrow1
        For col1 = 3 To maxcol1
            keyc = sh1.Cells(2, col1).Value
            keyr = sh1.Cells(row1, "B").Value
            If dicD.exists(keyr) = False Then
                MsgBox (keyr & "はSheet2に存在しません")
                sh1.Activate
                sh1.Cells(row1, "B").Select
                Exit Sub
            End If
            If keyc <> "" And sh1.Cells(row1, col1).Value <> "" Then
                col2 = dicH(keyc)
                row2 = dicD(keyr)
                sh2.Cells(row2, col2).Value = sh2.Cells(row2, col2).Value + sh1.Cells(row1, col1).Value
            End If
        Next
    Next
    MsgBox ("完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0ClB1YmxpYyBTdWIg5ZOB5ZCN5Yil6ZuG6KiIKCkKICAgIERpbSBzaDEgQXMgV29ya3NoZWV0CiAgICBEaW0gc2gyIEFzIFdvcmtzaGVldAogICAgRGltIGRpY0ggQXMgT2JqZWN0CiAgICBEaW0gZGljRCBBcyBPYmplY3QKICAgIERpbSBtYXhyb3cxIEFzIExvbmcKICAgIERpbSBtYXhyb3cyIEFzIExvbmcKICAgIERpbSBtYXhjb2wxIEFzIExvbmcKICAgIERpbSBtYXhjb2wyIEFzIExvbmcKICAgIERpbSByb3cxIEFzIExvbmcKICAgIERpbSByb3cyIEFzIExvbmcKICAgIERpbSBjb2wxIEFzIExvbmcKICAgIERpbSBjb2wyIEFzIExvbmcKICAgIERpbSBrZXljIEFzIFN0cmluZwogICAgRGltIGtleXIgQXMgU3RyaW5nCiAgICAKICAgIFNldCBkaWNIID0gQ3JlYXRlT2JqZWN0KCJTY3JpcHRpbmcuRGljdGlvbmFyeSIpICcg6YCj5oOz6YWN5YiX44Gu5a6a576pCiAgICBTZXQgZGljRCA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKSAnIOmAo+aDs+mFjeWIl+OBruWumue+qQogICAgU2V0IHNoMSA9IFdvcmtzaGVldHMoInNoZWV0MSIpCiAgICBTZXQgc2gyID0gV29ya3NoZWV0cygic2hlZXQyIikKICAgIG1heHJvdzEgPSBzaDEuQ2VsbHMoUm93cy5Db3VudCwgIkIiKS5FbmQoeGxVcCkuUm93ICdzaGVldDEg5pyA57WC6KGM44KS5rGC44KB44KLCiAgICBtYXhyb3cyID0gc2gyLkNlbGxzKFJvd3MuQ291bnQsICJCIikuRW5kKHhsVXApLlJvdyAnc2hlZXQyIOacgOe1guihjOOCkuaxguOCgeOCiwogICAgbWF4Y29sMSA9IHNoMS5DZWxscyg0LCBDb2x1bW5zLkNvdW50KS5FbmQoeGxUb0xlZnQpLkNvbHVtbiAgICdTaGVldDEg5pyA57WC5YiX44KS5rGC44KB44KLCiAgICBtYXhjb2wyID0gc2gyLkNlbGxzKDIsIENvbHVtbnMuQ291bnQpLkVuZCh4bFRvTGVmdCkuQ29sdW1uICAgJ1NoZWV0MiDmnIDntYLliJfjgpLmsYLjgoHjgosKICAgIElmIG1heHJvdzEgPCA1IFRoZW4gRXhpdCBTdWIKICAgIElmIG1heHJvdzIgPCAyIFRoZW4gRXhpdCBTdWIKICAgIElmIG1heGNvbDEgPCAzIFRoZW4gRXhpdCBTdWIKICAgIElmIG1heGNvbDIgPCAzIFRoZW4gRXhpdCBTdWIKICAgIEZvciBjb2wyID0gMyBUbyBtYXhjb2wyCiAgICAgICAga2V5YyA9IHNoMi5DZWxscygyLCBjb2wyKS5WYWx1ZQogICAgICAgIGRpY0goa2V5YykgPSBjb2wyCiAgICBOZXh0CiAgICBGb3Igcm93MiA9IDMgVG8gbWF4cm93MgogICAgICAgIGtleXIgPSBzaDIuQ2VsbHMocm93MiwgIkIiKS5WYWx1ZQogICAgICAgIGRpY0Qoa2V5cikgPSByb3cyCiAgICBOZXh0CiAgICBGb3IgY29sMSA9IDMgVG8gbWF4Y29sMQogICAgICAgIGtleWMgPSBzaDEuQ2VsbHMoMiwgY29sMSkuVmFsdWUKICAgICAgICBJZiBrZXljIDw+ICIiIFRoZW4KICAgICAgICAgICAgSWYgZGljSC5leGlzdHMoa2V5YykgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgICAgICBNc2dCb3ggKGtleWMgJiAi44GvU2hlZXQy44Gr5a2Y5Zyo44GX44G+44Gb44KTIikKICAgICAgICAgICAgICAgIHNoMS5BY3RpdmF0ZQogICAgICAgICAgICAgICAgc2gxLkNlbGxzKDIsIGNvbDEpLlNlbGVjdAogICAgICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICBGb3Igcm93MSA9IDUgVG8gbWF4cm93MQogICAgICAgIEZvciBjb2wxID0gMyBUbyBtYXhjb2wxCiAgICAgICAgICAgIGtleWMgPSBzaDEuQ2VsbHMoMiwgY29sMSkuVmFsdWUKICAgICAgICAgICAga2V5ciA9IHNoMS5DZWxscyhyb3cxLCAiQiIpLlZhbHVlCiAgICAgICAgICAgIElmIGRpY0QuZXhpc3RzKGtleXIpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAgICAgTXNnQm94IChrZXlyICYgIuOBr1NoZWV0MuOBq+WtmOWcqOOBl+OBvuOBm+OCkyIpCiAgICAgICAgICAgICAgICBzaDEuQWN0aXZhdGUKICAgICAgICAgICAgICAgIHNoMS5DZWxscyhyb3cxLCAiQiIpLlNlbGVjdAogICAgICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIElmIGtleWMgPD4gIiIgQW5kIHNoMS5DZWxscyhyb3cxLCBjb2wxKS5WYWx1ZSA8PiAiIiBUaGVuCiAgICAgICAgICAgICAgICBjb2wyID0gZGljSChrZXljKQogICAgICAgICAgICAgICAgcm93MiA9IGRpY0Qoa2V5cikKICAgICAgICAgICAgICAgIHNoMi5DZWxscyhyb3cyLCBjb2wyKS5WYWx1ZSA9IHNoMi5DZWxscyhyb3cyLCBjb2wyKS5WYWx1ZSArIHNoMS5DZWxscyhyb3cxLCBjb2wxKS5WYWx1ZQogICAgICAgICAgICBFbmQgSWYKICAgICAgICBOZXh0CiAgICBOZXh0CiAgICBNc2dCb3ggKCLlrozkuoYiKQpFbmQgU3ViCg==