我有点困惑。我有一本包含一系列图表的练习册。我得到的反馈是，他们想要一个额外的表，解释如何阅读图表。我当前的代码导出所有工作表，但现在我需要更新它以复制2张工作表。EG自动生成的图纸和命名图纸。我想新的工作簿，包括表1和10，然后另一个工作簿是表2和10，然后表3和10等。感谢帮助。

Sub CreateReports()

Dim ws As Worksheet
Dim pt As PivotTable
Dim shp As Shape
Dim pf As PivotField

Sheets("Source Data").Select

Columns("E").Replace What:="YES", Replacement:="Completed", LookAt:=xlWhole, MatchCase:=False
Columns("E").Replace What:="No", Replacement:="Not Completed", LookAt:=xlWhole, MatchCase:=False

Sheets("Main Pivot").Select

ActiveWorkbook.RefreshAll

'Create Division Sheets
On Error Resume Next
    ActiveSheet.PivotTables("MainPivot").ShowPages PageField:= _
        "User Custom Fields.Division2023"
    ActiveSheet.PivotTables("MainPivot").ShowPages PageField:= _
        "User Custom Fields.Department2023"
        
'UnProtect Sheet
Cells.Select
    ActiveSheet.Unprotect
        
'Loop Through
For Each ws In ActiveWorkbook.Worksheets
'Hide Top Row
'ws.Rows(1).Hidden = True
'Create Chart
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
    
'Protect Sheet
'ws.Protect Password:="Abc12345!", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
'UserInterfaceOnly:=True, AllowFormattingCells:=False, AllowFormattingColumns:=True, _
'AllowFormattingRows:=False, AllowInsertingColumns:=False, AllowInsertingRows:=False, _
'AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, _
'AllowSorting:=False, AllowFiltering:=False

        
Next ws
    
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & Training & "_" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
End Sub

字符串