Переделал на 4 столбца. Т.е. A и B не обрабатываются, берётся диапазон C:F^  
 
 
Option Explicit  
 
'1. создать массив "a" размером с число строк в А, на 2 поля в ширину.  
'2. загнать в словарь массив значений А, в Item порядковый номер уникального, сразу подсчитав в массиве "a" по этому номеру количество повторов и определив максимум.  
'3. создать массив "b" по полученным данным - размеру словаря и (максимум повторов)*6.  
'4. снова перебор столбца А и теперь уже в массив "a" во второе поле пишем номер повтора и по индексу словаря и этому номеру набираем данные в "b"  
'5. "b" выгружаем на лист.  
 
 
Sub IzEstToNado()  
   Dim iz, a, b, iLastRow As Long  
   Dim dic As Object, x, max_ As Long, i As Long, temp As Long  
 
   '1.  
   With Worksheets("Есть")  
       iLastRow = .Range("C" & Rows.Count).End(xlUp).Row  
       iz = Range(.[C2], .Cells(iLastRow, "F")).Value
   End With  
   ReDim a(1 To UBound(iz), 1 To 2)  
 
   '2  
   Set dic = CreateObject("Scripting.Dictionary")  
 
   For x = 1 To UBound(iz)  
       If dic.exists(CStr(iz(x, 1))) Then  
           temp = --dic.Item(CStr(iz(x, 1)))    'извлекаем порядковый номер уникального номера  
           a(temp, 1) = a(temp, 1) + 1      'считаем повторы  
           If max_ < a(temp, 1) Then max_ = a(temp, 1)    'определяем максимум повторов  
       Else  
           i = i + 1    'создаём порядковый номер уникального номера  
           dic.Add CStr(iz(x, 1)), i    'заносим порядковый номер уникального номера  
           a(i, 1) = 1    'количество повторов - первый :)  
       End If  
   Next  
 
   '3.  
   ReDim b(1 To dic.Count + 1, 1 To max_ * 4)  
   For i = 1 To max_ * 4 Step 4  
       b(1, i) = "Номер"  
       b(1, i + 1) = "Адрес"  
       b(1, i + 2) = "Количество"  
       b(1, i + 3) = "Допинформация"  
   Next  
 
   '4.  
   For x = 1 To UBound(iz)  
       If dic.exists(CStr(iz(x, 1))) Then  
           temp = --dic.Item(CStr(iz(x, 1)))    'порядковый номер уникального номера = индекс словаря  
           b(temp + 1, 1 + a(temp, 2)) = iz(x, 1)    'по индексу словаря и индексу повтора набираем данные в "b"  
           b(temp + 1, 2 + a(temp, 2)) = iz(x, 2)  
           b(temp + 1, 3 + a(temp, 2)) = iz(x, 3)  
           b(temp + 1, 4 + a(temp, 2)) = iz(x, 4)  
           a(temp, 2) = a(temp, 2) + 4    'во второе поле пишем индекс повтора  
       End If  
 
   Next  
 
   '5.  
   With Worksheets("Надо").[A1]
       .CurrentRegion.ClearContents  
       .Resize(UBound(b, 1), UBound(b, 2)).Value = b    'выгружаем результат  
   End With  
End Sub