Sub ФИКС_СОХРАНИТЬ()
Dim dic As Object, ikey, msg$
Dim book As Workbook, book1 As Workbook
Dim sht As Worksheet, i&, j&, x&, y&, arr(), arr1(), arr2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set book = ThisWorkbook
Set dic = CreateObject("scripting.dictionary")
Set sht = book.Sheets(5)
With sht
    arr1 = .Range("a1:i1")
    arr = .Range(.Cells(2, 1), Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
End With
j = UBound(arr, 2)
For i = LBound(arr) To UBound(arr)
    If arr(i, j) = "Курск" Then
        dic.Item(CStr(arr(i, j))) = dic.Item(CStr(arr(i, j))) + 1
    Else: dic.Item(CStr(arr(i, 6))) = dic.Item(CStr(arr(i, 6))) + 1
    End If
    MkDir book.Path & "\" & arr(i, j)
Next i
On Error GoTo 0
For Each ikey In dic.keys
    y = 0
    ReDim arr2(1 To dic.Item(ikey), 1 To j - 1)
    If ikey = "Курск" Then
        For i = 1 To UBound(arr)
            If arr(i, j) = ikey Then
                msg = arr(i, j): y = y + 1
                For x = 1 To UBound(arr2, 2)
                    arr2(y, x) = arr(i, x)
                Next x
            End If
        Next i
    Else
        For i = 1 To UBound(arr)
            If arr(i, 6) = ikey And arr(i, j) <> "Курск" Then
                msg = arr(i, j): y = y + 1
                For x = 1 To UBound(arr2, 2)
                    arr2(y, x) = arr(i, x)
                Next x
            End If
        Next i
    End If
Set book1 = Workbooks.add
With book1
    .SaveAs Filename:=book.Path & "\" & msg & "\" & ikey & ".xlsx"
    With .Sheets(1)
        .Range("a1").Resize(, UBound(arr1, 2)) = arr1
        .Range("a2").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
        .Cells.EntireColumn.AutoFit
    End With
    .Close True
End With
Next ikey
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub