t = el & "|" & k & "|" & "Получили"
           t2 = t & "|" & "V"
           If data_dic.exists(t2) Then aa(y, 1) = data_dic.Item(t2)

For Each p In data_dic.Item(t2)
   g = 0
   g = g + p
   Next

t2 = t & "|" & "B"
           If data_dic.exists(t2) Then aa(y, 2) = data_dic.Item(t2)

       Dim g As Integer
      Dim itogo As Object, s$
        Set itogo = CreateObject("Scripting.Dictionary"    
        itogo.Add s, data_dic.Item(t2)
        g = 0
      For Each p In itogo.Item(s)
      g = g + p
      Next
     G11 = g

 For i = 1 To UBound(a)
     t = a(i, 2)
     If Not city_dic.exists(t) Then city_dic.Add t, New Collection 

city_dic.Item(t).Add a(i, 1), a(i, 1) 

 With Sheets("Данные2"  ;)  
           Set exc_dic = CreateObject("Scripting.Dictionary"  ;)  : exc_dic.comparemode = 1
         iLastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
         b = Range(.[A5], .Range("B" & iLastrow)).Value
         w = 0
         w = w + 1
         b(1, w) = d
         If exc_dic.exists(d) = k Then b(w, 2) = exc_dic.Item(w, 2)
         End With 
Next
.[B4].Resize(1, 1) = b    'выгрузка данных
 

 t = el & "|" & k & "|" & "Получили"
          t2 = t & "|" & "V"
          If data_dic.exists(t2) Then aa(y, 1) = data_dic.Item(t2)
          t2 = t & "|" & "B"
          If data_dic.exists(t2) Then aa(y, 4) = data_dic.Item(t2)
          t2 = t & "|" & "F"
          If data_dic.exists(t2) Then aa(y, 7) = data_dic.Item(t2)
          t = el & "|" & k & "|" & "Выдали"
          t2 = t & "|" & "V"
          If data_dic.exists(t2) Then aa(y, 2) = data_dic.Item(t2)
          t2 = t & "|" & "B"
          If data_dic.exists(t2) Then aa(y, 5) = data_dic.Item(t2)
          t2 = t & "|" & "F"
          If data_dic.exists(t2) Then aa(y,  8)  = data_dic.Item(t2)
          t = el & "|" & k & "|" & "Результат"
          t2 = t & "|" & "V"
          If data_dic.exists(t2) Then aa(y, 3) = data_dic.Item(t2)
          t2 = t & "|" & "B"
          If data_dic.exists(t2) Then aa(y, 6) = data_dic.Item(t2)
          t2 = t & "|" & "F"
          If data_dic.exists(t2) Then aa(y, 9) = data_dic.Item(t2)

 ReDim aa(1 To x, 1 To 9) 

 .SaveAs ThisWorkbook.Path & "/" & k & ".xls" 

Sub compare() 
Dim tm!: tm = Timer 
 Dim a(), b(), c(), iLastrow As Long, i As Long, ii As Long, x As Byte 

 '1. 
 With Sheets(1) 
 iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row 
 a = Range(.[f1], .Range("A" & iLastrow)).Value 
 End With 

 With Sheets(2) 
 iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row 
 b = Range(.[a1], .Range("A" & iLastrow)).Value 
 End With 

 '2. 
 ReDim c(1 To UBound(b), 1 To 6) 

 With CreateObject("Scripting.Dictionary"  ;)  

 '3. 
 For i = 1 To UBound(a) 
 .Item(a(i, 1)) = i 
 Next 

 '4. 
 For i = 1 To UBound(b) 
 If .exists(b(i, 1)) Then 
 ii = .Item(b(i, 1)) 
 c(i, 1) = b(i, 1) 
 For x = 2 To 6: c(i, x) = a(ii, x): Next 
 End If 
 Next 
 End With 

 '5. 
 With Sheets(3) 
 .[a1].Resize(i - 1, 6) = c 
 .Activate 
 End With 

Debug.Print Timer - tm 
End Sub 

 Sub Counter() 
Dim Uniq As New Collection, iLastRow As Long, iLastColumn As Long
Dim i As Long, j As Long, Uniq2 As New Collection, iName As String, n As Long ' Arr1()
[I]iLastColumn = Cells(2, Columns.Count).End(xlToLeft).Column[/I]
[I]iLastRow = Cells(Rows.Count, 2).End(xlUp).Row[/I]
[I]Range(Cells(11, 1), Cells(iLastRow + 1, iLastColumn + 1)).ClearContents[/I]
[I]Range(Cells(11, 5), Cells(11, iLastColumn + 1)).ClearContents[/I]
[I]    With Sheets("Данные "[/I])
     iLastRow = .Cells(Rows.Count, 3).End(xlUp).Row
     For i = 5 To iLastRow
      On Error Resume Next
      Uniq.Add .Cells(i, 1), CStr(.Cells(i, 1))
     Next
     iLastRow = 1
     For i = 1 To Uniq.Count
      Cells(iLastRow + 1, 1) = Uniq(i)
      iLastRow = iLastRow + 1
     Next
     iLastRow = .Cells(Rows.Count, 3).End(xlUp).Row
     For i = 5 To iLastRow
      On Error Resume Next
      Uniq2.Add .Cells(i, 3), CStr(.Cells(i, 3))
     Next
     iLastColumn = 5
     For i = 1 To Uniq2.Count
      Cells(4, iLastColumn + 1) = Uniq2(i)
      iLastColumn = iLastColumn + 1
     Next
     iLastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
     iLastRow = .Cells(Rows.Count, 2).End(xlUp).Row
     For j = 4 To iLastColumn
      iName = Cells(2, j)
      For i = 1 To Uniq.Count
          For n = 3 To iLastRow
           If .Cells(n, 1) = iName Then
            If .Cells(n, 2) = Uniq(i) Then
                Cells(i + 2, j) = Cells(i + 2, j) + .Cells(n, 3)
            End If
           End If
          Next
      Next
     Next
'     Next
    End With
End Sub