VBA修改需求：自动生成工作表与指定表组合复制至新工作簿

以下是调整后的代码，实现将自动生成的数据透视表工作表与Sheet10组合导出为独立工作簿：

Sub CreateReports()

Dim ws As Worksheet
Dim pt As PivotTable
Dim shp As Shape
Dim pf As PivotField
Dim wsGuide As Worksheet ' 定义说明工作表变量
Dim FPath As String

' 定位说明工作表Sheet10，添加错误处理防止表不存在
On Error Resume Next
Set wsGuide = ThisWorkbook.Worksheets("Sheet10")
On Error GoTo 0
If wsGuide Is Nothing Then
    MsgBox "未找到指定的Sheet10工作表，请确认名称后重试", vbExclamation
    Exit Sub
End If

' 数据替换与透视表刷新
Sheets("Source Data").Columns("E").Replace What:="YES", Replacement:="Completed", LookAt:=xlWhole, MatchCase:=False
Sheets("Source Data").Columns("E").Replace What:="No", Replacement:="Not Completed", LookAt:=xlWhole, MatchCase:=False

Sheets("Main Pivot").Activate
ActiveWorkbook.RefreshAll

' 生成部门/分部工作表
On Error Resume Next
    ActiveSheet.PivotTables("MainPivot").ShowPages PageField:= _
        "User Custom Fields.Division2023"
    ActiveSheet.PivotTables("MainPivot").ShowPages PageField:= _
        "User Custom Fields.Department2023"
On Error GoTo 0

' 取消工作表保护（仅针对当前激活的Main Pivot表）
ActiveSheet.Unprotect

' 遍历工作表生成图表并设置透视表属性
For Each ws In ActiveWorkbook.Worksheets
    ' 跳过固定工作表，只处理自动生成的透视表工作表
    If ws.Name <> "Source Data" And ws.Name <> "Main Pivot" And ws.Name <> wsGuide.Name Then
        ' 生成图表
        On Error Resume Next
        Set pt = ws.PivotTables(1)
        On Error GoTo 0
        If Not pt Is Nothing Then
            Set shp = ws.Shapes.AddChart2(216, xlBarClustered)
            With shp.Chart
                On Error Resume Next
                .SetSourceData pt.TableRange2
                .ShowAllFieldButtons = False
                .SeriesCollection("Not Completed").Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
                .SeriesCollection("Completed").Format.Fill.ForeColor.RGB = RGB(146, 208, 80)
                .SeriesCollection("Not Completed").DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                .SeriesCollection("Completed").DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
                .Axes(xlValue).MaximumScale = 1
                .SetElement (msoElementDataLabelCenter)
            End With
            Set pt = Nothing
        End If

        ' 设置透视表属性
        On Error Resume Next
        With ws.PivotTables(1)
          .EnableDrilldown = True
          .EnableFieldList = False
          .EnableFieldDialog = False
          .PivotCache.EnableRefresh = False
          For Each pf In .PivotFields
            With pf
              .DragToPage = False
              .DragToRow = False
              .DragToColumn = False
              .DragToData = False
              .DragToHide = False
            End With
         Next pf
        End With

        On Error Resume Next
        Set pt = ws.PivotTables(1)
          For Each pf In pt.PivotFields
              pf.EnableItemSelection = False
          Next pf
    End If
Next ws

' 导出组合工作表
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Sheets
    ' 仅处理自动生成的工作表，跳过固定表
    If ws.Name <> "Source Data" And ws.Name <> "Main Pivot" And ws.Name <> wsGuide.Name Then
        ' 同时复制当前工作表和Sheet10到新工作簿
        Array(ws, wsGuide).Copy
        ' 保存新工作簿（注意：Training变量需提前定义或替换为实际名称）
        Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & Training & "_" & ws.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

关键修改说明 #

• 新增说明工作表定位：添加wsGuide变量定位Sheet10，并增加错误判断防止表不存在导致代码崩溃。
• 过滤固定工作表：在遍历生成图表和导出环节，跳过Source Data、Main Pivot和Sheet10，只处理自动生成的透视表工作表。
• 组合复制工作表：使用Array(ws, wsGuide).Copy替代原代码的ws.Copy，实现同时复制目标工作表和说明表到新工作簿。
• 优化错误处理：在关键步骤添加错误捕获，提升代码稳定性。

注意：原代码中的Training变量未定义，请确保该变量已在代码中声明并赋值，或直接替换为实际的文件名前缀（例如"Report"）。

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