Sub Разбивка_по_листам()
    Dim a As Variant, b As Variant
    Dim wb As Workbook, ws As Worksheet
    On Error GoTo Inform
    Set sd_sys = CreateObject("Scripting.Dictionary")
    Set a = Application.InputBox("Укажите столбец с регионом:", "Запрос данных", Type:=8)
    Set wb = Workbooks(a.Parent.Parent.Name)
    Set ws = wb.Worksheets(a.Parent.Name)
    rn = a(1).Address(0, 0)
    rw = 2 'Range(rn).Row
    cl = Range(rn).Column
    With ws
        If .AutoFilterMode Then .AutoFilterMode = False
        lr = .Cells(.Rows.Count, cl).End(xlUp).Row 'если в столбце регион будут пустые ячейки, то лучше использовать вместо cl номер столбца без пустых ячеек
        .Range("A" & rw - 1 & ":AF" & lr).AutoFilter
        arr_sys = .Range(.Cells(rw, cl), .Cells(lr, cl))
        For n = LBound(arr_sys) To UBound(arr_sys)
            If arr_sys(n, 1) = "" Then arr_sys(n, 1) = "(Пустые)"
            If Not sd_sys.Exists(arr_sys(n, 1)) Then sd_sys.Add arr_sys(n, 1), arr_sys(n, 1)
        Next
        If sd_sys.Count = 1 Then MsgBox "Всего одна система": Exit Sub
        ReDim arr_sp(0 To sd_sys.Count - 2)
        For Each y In sd_sys
            .Copy
            m = 0
            For Each y_1 In sd_sys
                If Not y = y_1 Then
                    If y_1 = "(Пустые)" Then y_1 = ""
                    arr_sp(m) = y_1
                    m = m + 1
                End If
            Next
            If y = "(Пустые)" Then sFlnm = "пусто" Else sFlnm = y
            sFldr = wb.Path & "\Region"
            ActiveSheet.Range(Cells(rw, cl), Cells(lr, cl)).AutoFilter Field:=cl, Criteria1:=Array(arr_sp), Operator:=xlFilterValues
            DeleteFilteredRows
            ActiveSheet.ShowAllData
            SaveAsAndClose sFldr, sFlnm
            wb.Activate
            .Select
        Next
    End With
    Exit Sub
Inform:
    MsgBox "Диапазон не выбран"
End Sub

Sub DeleteFilteredRows()
    Dim rng As Range
    On Error Resume Next
    Set rng = ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not rng Is Nothing Then
        rng.EntireRow.Delete
    End If
End Sub

Sub SaveAsAndClose(sFldr, sFlnm)
'Application.DisplayAlerts = False
    Dim wb_1 As Workbook
    Set wb_1 = ActiveWorkbook
    If Dir(sFldr, vbDirectory) = "" Then MkDir sFldr
    n = 1
    sFlnm_1 = sFlnm
    Do While Dir(sFldr & "\" & sFlnm_1 & ".xlsx") <> ""
        sFlnm_1 = sFlnm & " (" & n & ")"
        n = n + 1
        If n = 10 Then Exit Sub
    Loop
    If IsBookOpen(sFlnm_1 & ".xlsx") Then Workbooks(sFlnm_1 & ".xlsx").Close SaveChanges:=False 'True
    wb_1.SaveAs Filename:=sFldr & "\" & sFlnm_1 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wb_1.Close SaveChanges:=False
'Application.DisplayAlerts = True
End Sub

'https://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook
    For Each wbBook In Workbooks
        If wbBook.Name <> ThisWorkbook.Name Then
            If Windows(wbBook.Name).Visible Then
                If wbBook.Name = wbName Then IsBookOpen = True: Exit For
            End If
        End If
    Next wbBook
End Function