Option Explicit
 
Sub 重複データを削除し合算()
 
    Dim myDic As Object
    Dim myDic2 As Object
    Dim ws As Worksheet
    Dim maxrow As Long
    Dim wrow As Long
    Dim wrow2 As Long
    Dim Target As Variant
    Dim tmp As Variant
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    Set myDic = CreateObject("Scripting.Dictionary")
    Set myDic2 = CreateObject("Scripting.Dictionary")
    '最大行取得
    maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
    '出力先クリア
    ws.Range("H2:M" & Rows.Count).ClearContents
    For wrow = 2 To maxrow
        Target = Cells(wrow, "A").Value & "|" & Cells(wrow, "B").Value & "|" & Cells(wrow, "C").Value
        If myDic.exists(Target) = False Then
            'キーが最初に出現した場合
            myDic(Target) = Cells(wrow, "D").Value
            myDic2(Target) = wrow
        Else
            'キーが出現済みの場合
            myDic(Target) = myDic(Target) + Cells(wrow, "D").Value
        End If
    Next
    wrow2 = 2
    '全キーを処理する
    For Each Target In myDic.keys
        tmp = Split(Target, "|")
        ws.Cells(wrow2, "H").Value = tmp(0)     '商品名
        ws.Cells(wrow2, "I").Value = tmp(1)     'カテゴリ
        ws.Cells(wrow2, "J").Value = tmp(2)     '産地
        ws.Cells(wrow2, "K").Value = myDic(Target)  '個数
        wrow = myDic2(Target)
        ws.Cells(wrow2, "L").Value = ws.Cells(wrow, "E").Value '品番
        ws.Cells(wrow2, "M").Value = ws.Cells(wrow, "F").Value '品目
        wrow2 = wrow2 + 1
    Next
    Application.ScreenUpdating = True
 
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpTdWIg6YeN6KSH44OH44O844K/44KS5YmK6Zmk44GX5ZCI566XKCkKCiAgICBEaW0gbXlEaWMgQXMgT2JqZWN0CiAgICBEaW0gbXlEaWMyIEFzIE9iamVjdAogICAgRGltIHdzIEFzIFdvcmtzaGVldAogICAgRGltIG1heHJvdyBBcyBMb25nCiAgICBEaW0gd3JvdyBBcyBMb25nCiAgICBEaW0gd3JvdzIgQXMgTG9uZwogICAgRGltIFRhcmdldCBBcyBWYXJpYW50CiAgICBEaW0gdG1wIEFzIFZhcmlhbnQKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gRmFsc2UKICAgIFNldCB3cyA9IEFjdGl2ZVNoZWV0CiAgICBTZXQgbXlEaWMgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikKICAgIFNldCBteURpYzIgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikKICAgICfmnIDlpKfooYzlj5blvpcKICAgIG1heHJvdyA9IHdzLkNlbGxzKFJvd3MuQ291bnQsICJBIikuRW5kKHhsVXApLlJvdwogICAgJ+WHuuWKm+WFiOOCr+ODquOCogogICAgd3MuUmFuZ2UoIkgyOk0iICYgUm93cy5Db3VudCkuQ2xlYXJDb250ZW50cwogICAgRm9yIHdyb3cgPSAyIFRvIG1heHJvdwogICAgICAgIFRhcmdldCA9IENlbGxzKHdyb3csICJBIikuVmFsdWUgJiAifCIgJiBDZWxscyh3cm93LCAiQiIpLlZhbHVlICYgInwiICYgQ2VsbHMod3JvdywgIkMiKS5WYWx1ZQogICAgICAgIElmIG15RGljLmV4aXN0cyhUYXJnZXQpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAn44Kt44O844GM5pyA5Yid44Gr5Ye654++44GX44Gf5aC05ZCICiAgICAgICAgICAgIG15RGljKFRhcmdldCkgPSBDZWxscyh3cm93LCAiRCIpLlZhbHVlCiAgICAgICAgICAgIG15RGljMihUYXJnZXQpID0gd3JvdwogICAgICAgIEVsc2UKICAgICAgICAgICAgJ+OCreODvOOBjOWHuuePvua4iOOBv+OBruWgtOWQiAogICAgICAgICAgICBteURpYyhUYXJnZXQpID0gbXlEaWMoVGFyZ2V0KSArIENlbGxzKHdyb3csICJEIikuVmFsdWUKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgIHdyb3cyID0gMgogICAgJ+WFqOOCreODvOOCkuWHpueQhuOBmeOCiwogICAgRm9yIEVhY2ggVGFyZ2V0IEluIG15RGljLmtleXMKICAgICAgICB0bXAgPSBTcGxpdChUYXJnZXQsICJ8IikKICAgICAgICB3cy5DZWxscyh3cm93MiwgIkgiKS5WYWx1ZSA9IHRtcCgwKSAgICAgJ+WVhuWTgeWQjQogICAgICAgIHdzLkNlbGxzKHdyb3cyLCAiSSIpLlZhbHVlID0gdG1wKDEpICAgICAn44Kr44OG44K044OqCiAgICAgICAgd3MuQ2VsbHMod3JvdzIsICJKIikuVmFsdWUgPSB0bXAoMikgICAgICfnlKPlnLAKICAgICAgICB3cy5DZWxscyh3cm93MiwgIksiKS5WYWx1ZSA9IG15RGljKFRhcmdldCkgICflgIvmlbAKICAgICAgICB3cm93ID0gbXlEaWMyKFRhcmdldCkKICAgICAgICB3cy5DZWxscyh3cm93MiwgIkwiKS5WYWx1ZSA9IHdzLkNlbGxzKHdyb3csICJFIikuVmFsdWUgJ+WTgeeVqgogICAgICAgIHdzLkNlbGxzKHdyb3cyLCAiTSIpLlZhbHVlID0gd3MuQ2VsbHMod3JvdywgIkYiKS5WYWx1ZSAn5ZOB55uuCiAgICAgICAgd3JvdzIgPSB3cm93MiArIDEKICAgIE5leHQKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gVHJ1ZQoKRW5kIFN1Ygo=