Sub Макрос2()
Dim Tab1 As Variant
Dim Tab2 As Variant
Dim Tab3 As Variant
Dim Tab4 As Variant
Dim OpenForms
Dim LR As Long
Dim n As Long
Dim m As Long
Dim i As Integer
Dim Wb As Workbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False '0
Set Dict1 = CreateObject("Scripting.Dictionary")
Pa = ActiveWorkbook.Path & "\Районы\"
LR = Cells(Rows.Count, 1).End(xlUp).Row
Tab1 = Range("A2:N" & LR)
Tab4 = Range("A1:N1")
For n = LBound(Tab1) To UBound(Tab1)
    If Not Dict1.Exists(Left(Tab1(n, 1), 5)) Then
        Dict1.Add Left(Tab1(n, 1), 5), CStr(n)
    Else
        Dict1.Item(Left(Tab1(n, 1), 5)) = Dict1.Item(Left(Tab1(n, 1), 5)) & ";" & CStr(n)
    End If
Next n
Tab2 = Dict1.Keys
For n = 0 To Dict1.Count - 1
    Set Wb = Workbooks.Add
    Wb.Activate
    Tab3 = Split(Dict1.Item(Tab2(n)), ";")
    For m = LBound(Tab3) To UBound(Tab3)
        LR = Cells(Rows.Count, 1).End(xlUp).Row + 1
        For i = 1 To 14
            Cells(LR, i).NumberFormat = "@"
            Cells(LR, i) = CStr(Tab1(Tab3(m), i))
        Next i
    Next m
    Range("A1:N1") = Tab4
    Wb.SaveAs (Pa & Tab2(n) & ".xlsx")
    Wb.Close
    If n Mod 1000 = 0 Then OpenForms = DoEvents
Next n
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True

MsgBox "Обработка завершена создано - " & Dict1.Count & " файла"
'
End Sub