Option Explicit
Public Sub 在庫算出()
    Dim ws1 As Worksheet    '購入品／使用品
    Dim ws2 As Worksheet    '在庫
    Dim dicT1 As Object     '箱数
    Dim dicT2 As Object     '個包装
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim key As Variant
    Dim wrow As Long
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    ws2.Range("A3:C" & Rows.Count).ClearContents
    Set dicT1 = CreateObject("Scripting.Dictionary")
    Set dicT2 = CreateObject("Scripting.Dictionary")
    maxrow1 = ws1.Cells(Rows.Count, "D").End(xlUp).Row
    maxrow2 = ws1.Cells(Rows.Count, "G").End(xlUp).Row
    '購入品登録
    For wrow = 3 To maxrow1
        key = ws1.Cells(wrow, "D").Value
        If dicT1.exists(key) = False Then
            dicT1(key) = 0
            dicT2(key) = 0
        End If
        dicT1(key) = dicT1(key) + ws1.Cells(wrow, "E").Value    '箱数
        dicT2(key) = dicT2(key) + ws1.Cells(wrow, "F").Value    '個包装
    Next
    '使用品引き算
    For wrow = 3 To maxrow2
        key = ws1.Cells(wrow, "G").Value
        If dicT1.exists(key) = False Then
            MsgBox (key & "は購入品になし")
            ws1.Activate
            ws1.Cells(wrow, "G").Select
            Exit Sub
        End If
        dicT1(key) = dicT1(key) - ws1.Cells(wrow, "H").Value    '箱数
        dicT2(key) = dicT2(key) - ws1.Cells(wrow, "I").Value    '個包装
    Next
    '在庫
    wrow = 3
    For Each key In dicT1.keys()
        ws2.Cells(wrow, "A").Value = key
        If dicT1(key) <> 0 Then
            ws2.Cells(wrow, "B").Value = dicT1(key)
        End If
        If dicT2(key) <> 0 Then
            ws2.Cells(wrow, "C").Value = dicT2(key)
        End If
        wrow = wrow + 1
    Next
    MsgBox ("完了")
End Sub
 

T3B0aW9uIEV4cGxpY2l0ClB1YmxpYyBTdWIg5Zyo5bqr566X5Ye6KCkKICAgIERpbSB3czEgQXMgV29ya3NoZWV0ICAgICfos7zlhaXlk4HvvI/kvb/nlKjlk4EKICAgIERpbSB3czIgQXMgV29ya3NoZWV0ICAgICflnKjluqsKICAgIERpbSBkaWNUMSBBcyBPYmplY3QgICAgICfnrrHmlbAKICAgIERpbSBkaWNUMiBBcyBPYmplY3QgICAgICflgIvljIXoo4UKICAgIERpbSBtYXhyb3cxIEFzIExvbmcKICAgIERpbSBtYXhyb3cyIEFzIExvbmcKICAgIERpbSBrZXkgQXMgVmFyaWFudAogICAgRGltIHdyb3cgQXMgTG9uZwogICAgU2V0IHdzMSA9IFdvcmtzaGVldHMoIlNoZWV0MSIpCiAgICBTZXQgd3MyID0gV29ya3NoZWV0cygiU2hlZXQyIikKICAgIHdzMi5SYW5nZSgiQTM6QyIgJiBSb3dzLkNvdW50KS5DbGVhckNvbnRlbnRzCiAgICBTZXQgZGljVDEgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikKICAgIFNldCBkaWNUMiA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkRpY3Rpb25hcnkiKQogICAgbWF4cm93MSA9IHdzMS5DZWxscyhSb3dzLkNvdW50LCAiRCIpLkVuZCh4bFVwKS5Sb3cKICAgIG1heHJvdzIgPSB3czEuQ2VsbHMoUm93cy5Db3VudCwgIkciKS5FbmQoeGxVcCkuUm93CiAgICAn6LO85YWl5ZOB55m76YyyCiAgICBGb3Igd3JvdyA9IDMgVG8gbWF4cm93MQogICAgICAgIGtleSA9IHdzMS5DZWxscyh3cm93LCAiRCIpLlZhbHVlCiAgICAgICAgSWYgZGljVDEuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIGRpY1QxKGtleSkgPSAwCiAgICAgICAgICAgIGRpY1QyKGtleSkgPSAwCiAgICAgICAgRW5kIElmCiAgICAgICAgZGljVDEoa2V5KSA9IGRpY1QxKGtleSkgKyB3czEuQ2VsbHMod3JvdywgIkUiKS5WYWx1ZSAgICAn566x5pWwCiAgICAgICAgZGljVDIoa2V5KSA9IGRpY1QyKGtleSkgKyB3czEuQ2VsbHMod3JvdywgIkYiKS5WYWx1ZSAgICAn5YCL5YyF6KOFCiAgICBOZXh0CiAgICAn5L2/55So5ZOB5byV44GN566XCiAgICBGb3Igd3JvdyA9IDMgVG8gbWF4cm93MgogICAgICAgIGtleSA9IHdzMS5DZWxscyh3cm93LCAiRyIpLlZhbHVlCiAgICAgICAgSWYgZGljVDEuZXhpc3RzKGtleSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgIE1zZ0JveCAoa2V5ICYgIuOBr+izvOWFpeWTgeOBq+OBquOBlyIpCiAgICAgICAgICAgIHdzMS5BY3RpdmF0ZQogICAgICAgICAgICB3czEuQ2VsbHMod3JvdywgIkciKS5TZWxlY3QKICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICBFbmQgSWYKICAgICAgICBkaWNUMShrZXkpID0gZGljVDEoa2V5KSAtIHdzMS5DZWxscyh3cm93LCAiSCIpLlZhbHVlICAgICfnrrHmlbAKICAgICAgICBkaWNUMihrZXkpID0gZGljVDIoa2V5KSAtIHdzMS5DZWxscyh3cm93LCAiSSIpLlZhbHVlICAgICflgIvljIXoo4UKICAgIE5leHQKICAgICflnKjluqsKICAgIHdyb3cgPSAzCiAgICBGb3IgRWFjaCBrZXkgSW4gZGljVDEua2V5cygpCiAgICAgICAgd3MyLkNlbGxzKHdyb3csICJBIikuVmFsdWUgPSBrZXkKICAgICAgICBJZiBkaWNUMShrZXkpIDw+IDAgVGhlbgogICAgICAgICAgICB3czIuQ2VsbHMod3JvdywgIkIiKS5WYWx1ZSA9IGRpY1QxKGtleSkKICAgICAgICBFbmQgSWYKICAgICAgICBJZiBkaWNUMihrZXkpIDw+IDAgVGhlbgogICAgICAgICAgICB3czIuQ2VsbHMod3JvdywgIkMiKS5WYWx1ZSA9IGRpY1QyKGtleSkKICAgICAgICBFbmQgSWYKICAgICAgICB3cm93ID0gd3JvdyArIDEKICAgIE5leHQKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIK