Sub Макрос1()
    Dim LO As ListObject, i As Long, n As Long, SKU As String, ID As String

    Application.ScreenUpdating = False
    Set LO = ActiveSheet.ListObjects(1)
    With LO
        For i = .DataBodyRange.Rows.Count + 1 To 1 Step -1
            If InStr(1, .Range.Cells(i, 2), ",", vbTextCompare) > 0 Then
                SKU = .Range.Cells(i, 1)
                ID = .Range.Cells(i, 2)
                .Range.Cells(i, 1) = SKU & "-" & Split(ID, ",")(0) 'SKU
                .Range.Cells(i, 2) = Split(ID, ",")(0) 'ID
                For n = 1 To UBound(Split(ID, ","))
                    .ListRows.Add (i + n - 1)
                    .ListRows(i - 1).Range.Copy .ListRows(i + n - 1).Range
                    .Range.Cells(i + n, 1) = SKU & "-" & Split(ID, ",")(n) 'SKU
                    .Range.Cells(i + n, 2) = Split(ID, ",")(n) 'ID
                Next n
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    MsgBox "Конец", vbInformation, ""
End Sub

Sub SumStages()
    Dim SvodSht As Worksheet, TempSht As Worksheet, LastRow As Long, LastCol As Long
    
    Application.ScreenUpdating = False
    Set SvodSht = Worksheets("СВОД")
    SvodSht.Cells.Clear
    Worksheets("Этап 1").Range("A1").CurrentRegion.Copy SvodSht.Range("A1")
    With SvodSht
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    For Each TempSht In Worksheets
        If TempSht.Name <> "Этап 1" And TempSht.Name <> SvodSht.Name Then
            With TempSht
                .Range("C2", .Cells(LastRow - 1, LastCol)).Copy
            End With
            SvodSht.Range("C2").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
        End If
    Next TempSht
    SvodSht.Activate
    SvodSht.Range("A1").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Данные просуммированы!", vbInformation, "Конец"
End Sub

Sub Split_Table_To_Files()
    Dim arrData, Dict As Object, i As Long, LO As ListObject, wsSheetData As Worksheet
    Dim sDepartment As String, vKey As Variant, lCounter As Long, Rng As Range
    
    If MsgBox("Split the table into separate files by departments?", vbQuestion + vbYesNo, "Question") = vbNo Then Exit Sub
    
    Set wsSheetData = ActiveSheet
    On Error Resume Next
    Set LO = wsSheetData.ListObjects("Table1")
    On Error GoTo 0
    
    If LO Is Nothing Then
        MsgBox "There is no 'Table1' on the active sheet!", vbExclamation, "Error"
        Exit Sub
    End If
    
    LO.AutoFilter.ShowAllData
    arrData = LO.Range.Value
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    For i = 2 To UBound(arrData)
        sDepartment = arrData(i, 1)
        If sDepartment <> "Total" Then
            If Not Dict.Exists(sDepartment) Then Dict(sDepartment) = 0&
        End If
    Next i
    
    If Dict.Count = 0 Then
        MsgBox "It was not possible to collect the unique names of the departments!", vbExclamation, "Error"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo errHandler:
     
    For Each vKey In Dict.Keys
        ActiveSheet.Copy
        Set LO = ActiveSheet.ListObjects(1)
        With LO
            .AutoFilter.ShowAllData
            .Range.AutoFilter Field:=1, Criteria1:="<>" & vKey
            '-2 - это оставляем строку Итогов
            Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 2, .AutoFilter.Range.Columns.Count).SpecialCells(xlCellTypeVisible)
            Rng.Delete
            .AutoFilter.ShowAllData
        End With
        
        With ActiveSheet
            .Columns(1).ColumnWidth = 40
            .Range("A1").Select
            .Cells.Locked = True
            .Columns("H:H").Locked = False
            .Columns("K:M").Locked = False
            .Protect Password:="2106", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingColumns:=True, AllowSorting:=True, AllowFiltering:=True
        End With
        ActiveWindow.LargeScroll Down:=-1000
        If Dir(ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx") <> "" Then
            Kill ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx"
        End If
        ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & vKey & ".xlsx", xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close (False)
        lCounter = lCounter + 1
    Next vKey
 
errHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Created " & lCounter & " files!", vbInformation, "Finish"
End Sub

Private Sub CopySheetsToWB1_Click()
    Dim wb As Workbook
    'Me.TextBox1.Text = "Книга122.xlsx"
    If InStr(1, Me.TextBox1.Text, ".", vbTextCompare) = 0 Then
        MsgBox "Какого хрена не указал расширение файла (.XLSX)?", vbExclamation, "Будь внимательнее!!!"
        Exit Sub
    End If
    On Error Resume Next
    Set wb = Workbooks(Me.TextBox1.Text)
    On Error GoTo 0
    If wb Is Nothing Then
        MsgBox "Нет такого окрытого файла: " & Me.TextBox1.Text, vbExclamation, "Будь внимательнее!!!"
        Exit Sub
    End If
    ThisWorkbook.Sheets(1).Copy After:=wb.Sheets(1)
    MsgBox "Лист скопирован!", vbInformation, "Копирование листа"
End Sub