按條件拆分Excel內容並另存爲單獨的工作簿

Option Explicit

Sub SplitInfomation()
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets(1)
        '按單位名稱排序
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("AD3:AD7"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range("A3:AH7")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        '將單位名稱填入數組
        Dim Company() As String
        Dim CompanyCount As Long
        Dim CompanyIndex As Long
        CompanyCount = .Range("AD65536").End(xlUp).Row - 3
        For CompanyIndex = 0 To CompanyCount
            ReDim Preserve Company(CompanyIndex)
            Company(CompanyIndex) = .Range("AD" & CompanyIndex + 3)
        Next
        
        '單位名稱去重
        Dim NewCompany() As String
        Dim NewCompanyIndex As Long
        For CompanyIndex = 0 To UBound(Company) - 1
            For NewCompanyIndex = CompanyIndex + 1 To UBound(Company)
                If Company(CompanyIndex) = Company(NewCompanyIndex) Then
                   Company(NewCompanyIndex) = ""
                End If
            Next
        Next
        
        '輸出去重後單位名稱數組
        NewCompanyIndex = 0
        For CompanyIndex = 0 To UBound(Company)
            If Company(CompanyIndex) <> "" Then
                ReDim Preserve NewCompany(NewCompanyIndex)
                NewCompany(NewCompanyIndex) = Company(CompanyIndex)
                NewCompanyIndex = NewCompanyIndex + 1
            End If
        Next
        
        '新建工作簿
        Dim RowStartIndex As Long
        Dim RowEndIndex As Long
        RowEndIndex = 2
        Application.DisplayAlerts = False
        For NewCompanyIndex = 0 To UBound(NewCompany)
            '新建工作簿
            Workbooks.Add
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewCompany(NewCompanyIndex) & ".xls", FileFormat:=56 'xlExcel8
            '複製表頭
            .Range("A1:AH2").Copy
            Workbooks(NewCompany(NewCompanyIndex) & ".xls").Sheets(1).Range("A1").PasteSpecial xlPasteAll
            .Range("A:AH").Copy
            Workbooks(NewCompany(NewCompanyIndex) & ".xls").Sheets(1).Range("A:AH").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            '複製內容
            RowStartIndex = RowEndIndex
            Do Until .Range("AD" & RowStartIndex) = NewCompany(NewCompanyIndex)
                RowStartIndex = RowStartIndex + 1
            Loop
            RowEndIndex = CompanyCount + 3
            Do Until .Range("AD" & RowEndIndex) = NewCompany(NewCompanyIndex)
                RowEndIndex = RowEndIndex - 1
            Loop
            .Range("A" & RowStartIndex & ":AH" & RowEndIndex).Copy
            Workbooks(NewCompany(NewCompanyIndex) & ".xls").Sheets(1).Range("A3").PasteSpecial xlPasteAll
            Workbooks(NewCompany(NewCompanyIndex) & ".xls").Save
            Workbooks(NewCompany(NewCompanyIndex) & ".xls").Close
        Next
        MsgBox "拆分完成，請進行下一步工作"
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub