Разнести таблицу из одного файла в другие

    Range("H1").Select
    Range(Selection, Selection.End(xlDown)).Select

Option Explicit
 
Sub tt()
    Dim a(), i&, ii&, k
 
    With CreateObject("Scripting.Dictionary"): .comparemode = 1
        a = ActiveSheet.UsedRange.Value
        For i = 1 To UBound(a): .Item(a(i, 8)) = .Item(a(i, 8)) + 1: Next
        For Each k In .keys
            ReDim b(1 To .Item(k), 1 To 6): ii = 0
            For i = 1 To UBound(a)
                If a(i, 8) = k Then
                    ii = ii + 1
                    b(ii, 1) = k
                    b(ii, 2) = a(i, 1)
                    b(ii, 3) = a(i, 4)
                    b(ii, 4) = a(i, 6)
                    b(ii, 5) = a(i, 7)
                    b(ii, 6) = a(i, 9)
                End If
            Next
            Worksheets.Add(After:=Sheets(Sheets.Count)).[a1].Resize(ii, 6) = b
        Next
 
    End With
End Sub

    ChDir "D:\file\out"
    Workbooks.Open Filename:="D:\file\out\1.xls"
 
    Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("L:L").Cut
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("L:L").Delete Shift:=xlToLeft
    
    Cells.Select
    Selection.Copy
    Windows("2.xls").Activate
    Cells.Select
    ActiveSheet.Paste
    Windows("1.xls").Activate
    ActiveWindow.Close

Application.DisplayAlerts = False