使用VBA按团队拆分含多工作表的Excel工作簿

需求 #

将包含「Comm_Sum」「KPI」等多个工作表的Excel工作簿，按各工作表的Team列拆分，把对应团队的数据复制到新工作簿的对应工作表中。

初始问题 #

最初编写的VBA代码无法完成FilterRange2对应的数据复制到新工作簿Sheet2的操作，持续抛出「runtime error 424（对象必需）」错误。

初始错误代码 #

Sub Splitting()

Dim OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim UniqueNames  As New Collection

Dim LastRow As Long, LastCol As Long, _
    TeamCol As Long, tIndex As Long, kIndex As Long
Dim OutName As String

' 预先设置引用和变量，方便后续操作
' 处理Comm_Sum工作表
Set DataSheet = ThisWorkbook.Worksheets("Comm_Sum")

TeamCol = 4
LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol))

' 遍历Team列，将唯一团队名称存入集合
For tIndex = 2 To LastRow
    On Error Resume Next
        UniqueNames.Add Item:=DataSheet.Cells(tIndex, TeamCol), Key:=DataSheet.Cells(tIndex, TeamCol)
    On Error GoTo 0
Next tIndex

' 处理KPI工作表
Dim DataSheet2 As Worksheet
Dim kTeamCol As Long
Dim LastRow2 As Long, LastCol2 As Long
Dim FilterRange2 As Range

Set DataSheet2 = ThisWorkbook.Worksheets("KPI")

kTeamCol = 4
LastRow2 = DataSheet2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastCol2 = DataSheet2.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FilterRange2 = Range(DataSheet2.Cells(3, 1), DataSheet2.Cells(LastRow2, LastCol2))

' 再次遍历Comm_Sum的Team列，存入唯一团队名称（重复操作）
Set DataSheet = ThisWorkbook.Worksheets("Comm_Sum")

For tIndex = 2 To LastRow
    On Error Resume Next
        UniqueNames.Add Item:=DataSheet.Cells(tIndex, TeamCol), Key:=DataSheet.Cells(tIndex, TeamCol)
    On Error GoTo 0
Next tIndex

' 遍历KPI的Team列，存入唯一团队名称
Set DataSheet2 = ThisWorkbook.Worksheets("KPI")

For kIndex = 4 To LastRow2
    On Error Resume Next
        UniqueNames2.Add Item:=DataSheet2.Cells(kIndex, kTeamCol), Key:=DataSheet2.Cells(tIndex, kTeamCol)
    On Error GoTo 0
Next kIndex

' 遍历唯一团队名称集合，生成新工作簿并保存为团队名称.xls
Application.DisplayAlerts = False
' 处理Comm_Sum数据
For tIndex = 1 To UniqueNames.Count
    Set OutBook = Workbooks.Add
    Set OutSheet = OutBook.Sheets(1)
    ActiveWorkbook.Sheets.Add
    Set OutSheet2 = OutBook.Sheets(2)
    With FilterRange
        .AutoFilter Field:=TeamCol, Criteria1:=UniqueNames(tIndex)
        .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")

    End With
Next tIndex

' 处理KPI数据
For kIndex = 4 To UniqueNames2.Count
    Set OutSheet2 = OutBook.Sheets(2)
    With FilterRange2
        .AutoFilter Field:=TeamCol2, Criteria1:=UniqueNames2(kIndex)
        .SpecialCells(xlCellTypeVisible).Copy OutSheet2.Range("A1")

End With
Next kIndex

' 设置新工作簿名称
oWBName = ThisWorkbook.FullName

If InStr(oWBName, ".") > 0 Then
   oWBName = Left(oWBName, InStr(oWBName, ".") - 1)
End If
   
    OutName = oWBName & UniqueNames(tIndex)
    OutBook.SaveAs Filename:=OutName, FileFormat:=xlExcel8
    OutBook.Close SaveChanges:=False
Call ClearAllFilters(DataSheet)

Application.DisplayAlerts = True


End Sub

' 安全清除数据工作表的所有筛选
Sub ClearAllFilters(TargetSheet As Worksheet)
    With TargetSheet
        TargetSheet.AutoFilterMode = False
        If .FilterMode Then
            .ShowAllData
        End If
    End With
End Sub

问题解决（2024年2月26日更新） #

已实现可行方案，更新后的VBA代码可按指定团队完成拆分并保存功能：

可行代码 #

Sub Split()
Dim Team(100) As String
Dim Alias(100) As String
Dim TeamMail(100) As String
Dim xTeam As String

Dim OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim FilterRange As Range
Dim LastRow As Long, LastCol As Long, _
NameCol As Long, Index As Long
Dim OutName As String
Dim Savepath As String

' 预先设置引用和变量，方便后续操作
Set DataSheet = ThisWorkbook.Worksheets("Comm_Sum")
Set DataSheet2 = ThisWorkbook.Worksheets("KPI")

Savepath = "C:\Users\XXX\XXX\XXX\"

' 定义Comm_Sum的数据范围
NameCol = 4

LastRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

LastCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set FilterRange = Range(DataSheet.Cells(1, 1), DataSheet.Cells(LastRow, LastCol))

' 定义KPI的数据范围
NameCol2 = 2

LastRow2 = DataSheet2.Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

LastCol2 = DataSheet2.Cells.Find("*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column

Set FilterRange2 = Range(DataSheet2.Cells(1, 1), DataSheet2.Cells(LastRow2, LastCol2))

Application.DisplayAlerts = False

' 指定需要拆分的团队
Team(1) = "John Smith"
Team(2) = "Jenny Smith"

' 遍历指定团队，生成对应工作簿
For i = 1 To 2
xTeam = Team(i)

Set OutBook = Workbooks.Add
OutBook.Worksheets.Add
Set OutSheet = OutBook.Sheets(1)
Set OutSheet2 = OutBook.Sheets(2)

' 复制Comm_Sum中对应团队的数据到新工作簿Sheet1
With FilterRange
    .AutoFilter Field:=NameCol, Criteria1:=xTeam
    .SpecialCells(xlCellTypeVisible).Copy OutSheet.Range("A1")
End With

' 复制KPI中对应团队的数据到新工作簿Sheet2
With FilterRange2
    .AutoFilter Field:=NameCol2, Criteria1:=xTeam
    .SpecialCells(xlCellTypeVisible).Copy OutSheet2.Range("A1")
End With

' 设置新工作簿名称并保存
OutName = xTeam & ".xlsx"
OutBook.SaveAs Filename:=Savepath & OutName, FileFormat:=xlOpenXMLWorkbook
OutBook.Close SaveChanges:=False

' 清除筛选
Call ClearAllFilters(DataSheet)

Next i

Application.DisplayAlerts = True

End Sub

' 安全清除数据工作表的所有筛选
Sub ClearAllFilters(TargetSheet As Worksheet)
With TargetSheet
    TargetSheet.AutoFilterMode = False
    If .FilterMode Then
        .ShowAllData
    End If
End With
End Sub

注：更新后的代码修正了初始代码中的核心问题：

• 移除重复的团队名称收集逻辑，改为直接指定目标团队，简化流程
• 将两个工作表的拆分逻辑整合到同一个循环中，确保OutBook对象始终有效
• 修正代码中的拼写错误（如x1ByRows改为xlByRows、Criterial改为Criteria1等）
• 明确指定保存路径，避免路径歧义

内容的提问来源于stack exchange，提问作者Ed K