Sub test()
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
k = 0
Set a = Workbooks("Пример.xlsm").Sheets("Лист3")
For i = 2 To lLastRow
k = Cells(i, 3)
If Len(Dir(Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx")) > 0 Then
Workbooks.Open Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
lLastRowb = b.Cells(Rows.Count, 1).End(xlUp).Row
For q = 2 To lLastRowb + 1
If b.Cells(q, 1) = "" Then
b.Cells(q, 1) = b.Cells(q - 1, 1) + 1
Exit For
End If
Next q
b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
ActiveWorkbook.Close True
Else
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Workbooks("Пример.xlsm").Path & "\" & k & ".xlsx"
Set b = ActiveWorkbook.Sheets("Лист1")
For q = 1 To 3
b.Cells(1, q) = a.Cells(1, q)
If q = 1 Then
b.Cells(2, q) = 1
Else
b.Cells(2, q) = a.Cells(i, q)
End If
Next q
ActiveWorkbook.Close True
End If
Next i
End Sub

Sub Razbivka()
Dim iLastRow As Long
Dim iLR_Unic As Long
Dim i As Long
Dim Town As String
Dim FoundTown As Range
Dim FAdr As String
Dim n As Integer
Dim IsxodList As Worksheet
  'отключаем обновление экрана, предупреждения и автоматическое вычисление
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlManual
   Set IsxodList = ThisWorkbook.ActiveSheet
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("H1:H" & iLastRow).ClearContents
 Range("C1:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
    iLR_Unic = Cells(Rows.Count, 8).End(xlUp).Row
  For i = 2 To iLR_Unic    'цикл по уникальным городам
    Town = Cells(i, 8)     'очередной город
     Set FoundTown = Columns(3).Find(Town, , xlValues, xlWhole)
          If Not FoundTown Is Nothing Then               'нашли город в столбце С
            FAdr = FoundTown.Address                     'адрес первого вхождения
            Workbooks.Add (xlWBATWorksheet)              'создать книгу с одним листом
             IsxodList.Range("A1:C1").Copy Range("A1")   'копируем шапку
              n = 1
            Do
                n = n + 1
              IsxodList.Range("A" & FoundTown.Row & ":C" & FoundTown.Row).Copy Cells(n, "A")
              Columns("A:C").AutoFit
              Columns("B:B").HorizontalAlignment = xlLeft
                Set FoundTown = IsxodList.Columns(3).FindNext(FoundTown)
            Loop While FoundTown.Address <> FAdr
              ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Town & ".xls"
              ActiveWorkbook.Close SaveChanges:=True
          End If
  Next
'включаем все, что отключали
    .Calculation = xlAutomatic
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
b.Cells(q, 3) = a.Cells(i, 4)
b.Cells(q, 3) = a.Cells(i, 5)
b.Cells(q, 3) = a.Cells(i, 6)

b.Cells(q, 2) = a.Cells(i, 2)
b.Cells(q, 3) = a.Cells(i, 3)
b.Cells(q, 4) = a.Cells(i, 4)
b.Cells(q, 5) = a.Cells(i, 5)
b.Cells(q, 6) = a.Cells(i, 6)

   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row