Sub АнализЗаказов()
Dim arr()
Dim dic As Object
Dim I&
Dim iKey, iTmp
Application.ScreenUpdating = False
On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  With ActiveSheet
    arr = .Range("A2:D" & .UsedRange.Rows.Count).Value
  End With
  ReDim arrNew(LBound(arr, 1) To UBound(arr, 1), 1 To 1)
  For I = LBound(arr, 1) To UBound(arr, 1)
    If Not IsEmpty(arr(I, 1)) Then
      iKey = arr(I, 1)
      If Not dic.Exists(iKey) Then
        dic.Add iKey, arr(I, 2)
      Else
        iTmp = dic(iKey)
        iTmp = iTmp + arr(I, 2)
        dic(iKey) = iTmp
      End If
    End If
  Next
  With CreateObject("Scripting.Dictionary")
    For I = LBound(arr, 1) To UBound(arr, 1)
      If Not IsEmpty(arr(I, 3)) Then
        iKey = arr(I, 3)
        If Not .Exists(iKey) Then
          .Add iKey, arr(I, 4)
        Else
          iTmp = .Item(iKey)
          iTmp = iTmp + arr(I, 4)
          .Item(iKey) = iTmp
        End If
        If dic.Exists(iKey) Then
          iTmp = .Item(iKey)
          iTmp = iTmp - dic(iKey)
          .Item(iKey) = iTmp
        End If
      End If
    Next
    Worksheets("Лист2").Range("A1").Resize(.Count) = Application.Transpose(.Keys)
    Worksheets("Лист2").Range("B1").Resize(.Count) = Application.Transpose(.Items)
  End With
  With Worksheets("Лист2")
    .Columns(1).EntireColumn.AutoFit
    .Activate
  End With
Application.ScreenUpdating = True
End Sub