Sub qwe()
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
Dim w1 As Worksheet: Set w1 = ThisWorkbook.Sheets("qword")
Dim w2 As Worksheet: Set w2 = ThisWorkbook.Sheets("Ëèñò1")
Dim i As Long
    i = w1.Cells(Rows.Count, 1).End(xlUp).Row
    w2.Cells.Clear
    w1.Range("A1:G8").Copy w2.Cells(1, 1)
    
    For n = 9 To i
        If w1.Range("K" & n) = "Ãîðîä ÀÂ" Then
            w2.Cells.Clear
            w1.Range("A1:G8").Copy w2.Cells(1, 1)
            q = n + 1
            Do While w1.Range("D" & q + 1) = w1.Range("D" & n + 1)
                q = q + 1
            Loop
            w1.Range("A" & n & ":G" & q).Copy w2.Range("A9")
            Name = ""
                Z = Len(w1.Range("A" & n))
                For zz = 1 To Z
                    If Mid(w1.Range("A" & n), zz, 1) = "/" Then Exit For
                    If Mid(w1.Range("A" & n), zz, 1) <> "¹" And Mid(w1.Range("A" & n), zz, 1) <> Chr(34) And Mid(w1.Range("A" & n), zz, 1) <> "'" Then
                        Name = Name & Mid(w1.Range("A" & n), zz, 1)
                    End If
                Next zz
            
'            ThisWorkbook.SaveAs Filename:="C:\Desktop\" & Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            ActiveWorkbook.SaveAs Filename:="C:\Users\gizhunov_a\Desktop\" & Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        End If
    Next n
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
End Sub