Sub Нарезать()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim dicOpenWb As Object: Set dicOpenWb = CreateObject("Scripting.Dictionary")
    RememberWBs dicOpenWb
    Dim sh As Worksheet
    Set sh = ActiveSheet
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 3).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, 3), .Cells(y, 3))
    End With
    
    Dim gorod As String
    Dim wb As Workbook
    Dim r As Range
    For y = 1 To UBound(a, 1)
        gorod = a(y, 1)
        Set wb = GetWB(gorod, sh)
        With wb.Sheets(1)
            Set r = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
        End With
        sh.Rows(y).Copy r
    Next
    
    CloseWBs dicOpenWb
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
End Sub

Function GetWB(gorod As String, shParent As Worksheet) As Workbook
    Dim wb As Workbook
    On Error Resume Next
        Set wb = Workbooks(gorod & ".xlsm")
        If wb Is Nothing Then
            Set wb = Workbooks.Add
            Dim s As String
            s = ThisWorkbook.Path & "\" & gorod & ".xlsm"
            Kill s
            wb.SaveAs s, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            Dim i As Integer
            Application.DisplayAlerts = False
            For i = wb.Worksheets.Count To 2 Step -1
                wb.Worksheets(i).Delete
            Next
            Application.DisplayAlerts = True
            shParent.Rows(1).Copy
            wb.Worksheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    On Error GoTo 0
    Set GetWB = wb
End Function

Private Sub RememberWBs(dic As Object)
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        dic(wb.Name) = 0
    Next
End Sub

Private Sub CloseWBs(dic As Object)
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If dic.exists(wb.Name) Then
        Else
            wb.Close True
        End If
    Next
End Sub