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

Sub sorting()
    Dim pDict As Object, lRow As Long, rCol As Long
    Dim pHeader As Range, pRow As Range, pSheet As Worksheet
    Dim sKey As String, pItem As Variant, vData As Variant, i As Long
    Set pSheet = ActiveSheet
    Set pDict = CreateObject("Scripting.Dictionary")
    lRow = pSheet.Range("A2").End(xlDown).Row
    rCol = pSheet.Range("A2").End(xlToRight).Column
    Set pHeader = pSheet.Range(pSheet.Cells(2, 1), pSheet.Cells(2, rCol))
    vData = pSheet.Range(pSheet.Cells(3, 1), pSheet.Cells(lRow, 1)).Value
    For i = 1 To UBound(vData)
        sKey = Mid$(vData(i, 1), 1, 5)
        If Not pDict.Exists(sKey) Then
            pDict.Add sKey, pHeader
        End If
        Set pDict(sKey) = Application.Union(pDict(sKey), pSheet.Range(pSheet.Cells(i + 2, 1), pSheet.Cells(i + 2, rCol)))
    Next
    For Each pItem In pDict.Items
        pItem.Copy Application.Workbooks.Add.Worksheets(1).Range("A2")
    Next
End Sub