如何防止数据透视图成为工作表副本上的常规图表？

Question

使用Excel 2010,我编写了一些VBA来将选定的工作表从主工作簿复制到客户端工作簿.该代码可以很好地复制具有与数据关联的数据和数据透视表的数据表,以及具有一个或多个数据透视图的图表工作表到新工作簿.

问题是在目标工作簿中,图表不再是数据透视图,它们是常规图表,其源数据范围是空白的.Master PivotChart的源数据已填写,但显示为灰色,因此无法编辑.

将工作表从一个工作簿复制到另一个工作簿(在此行XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count):)时会立即出现此问题,但我将包含该调用的代码Subs.当它到达那些线时,图表已经被打破

问题是三部分:

1. 我可以阻止数据透视图转换为副本中的常规图表吗？即是否有.Copy我错过的旗帜/场景？
2. 如果没有,我可以通过某种方式再次将图表更新为数据透视图cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable吗？
3. 如果失败了,那么在复制的工作表中从头开始创建数据透视图的最佳方法是什么？

笔记:

1. 这些是标准的Excel数据透视表,我没有使用PowerPivot.不过,我对此持开放态度,如果能解决这个问题的话.刚刚对PowerPivot进行了一些阅读,我认为它不会对我有所帮助,但是,我再次接受建议.
2. 回应Jens的评论,原始数据和数据透视表位于一张纸上,而数据透视表位于第二张纸上.

这是代码.除了复制具有完整数据透视图的工作表作为数据透视图之外,它的工作效果非常好.

  While Not SlideRS.EOF                                                   'loop through all the supporting data sheets for this graph sheet
    If SlideRS.Fields(1) <> SlideRS.Fields(2) Then                        'the worksheet depends on something else, copy it first
      If InStr(1, UsedSlides, SlideRS.Fields(2)) = 0 Then                 'if the depended upon slide is not in the list of UsedSlides, then add it
        Form_Master.ProcessStatus.Value = "Processing: " & ClinicName & "  Slide: " & SlideRS!SlideName & "    Worksheet: " & SlideRS.Fields(2).Value
        XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)
        Set NewSheet = XLClinic.Sheets(XLClinic.Sheets.Count)
        UsedSlides = UsedSlides & "," & NewSheet.Name
        UpdateCharts XLMaster.Sheets(SlideRS.Fields(2).Value), NewSheet
        ProcessDataSheet NewSheet, NewXLName
        Set NewSheet = Nothing
      End If
    End If
    SlideRS.MoveNext                                                      'move to the next record of supporting Data sheets
  Wend

这是代码UpdateCharts.其目的是将颜色从Master复制到客户端工作表,因为Excel似乎喜欢为新图表指定随机颜色

Private Sub UpdateCharts(ByRef Master As Worksheet, ByRef Clinic As Worksheet)

Dim MChart As Excel.ChartObject
Dim CChart As Excel.ChartObject
Dim Ser As Excel.Series
Dim pnt As Excel.point
Dim i As Integer
Dim Color() As Long
Dim ColorWheel As ChartColors

  Set ColorWheel = New ChartColors
  For Each MChart In Master.ChartObjects
    For Each CChart In Clinic.ChartObjects
      If CChart.Name = MChart.Name Then
        If CChart.Chart.ChartType = xlPie Or _
           CChart.Chart.ChartType = xl3DPie Or _
           CChart.Chart.ChartType = xl3DPieExploded Or _
           CChart.Chart.ChartType = xlPieExploded Or _
           CChart.Chart.ChartType = xlPieOfPie Then
          If InStr(1, CChart.Name, "ColorWheel") Then                  'this pie chart needs to have pre-defined colors assigned
            i = 1
            For Each pnt In CChart.Chart.SeriesCollection(1).Points
              pnt.Format.Fill.ForeColor.RGB = ColorWheel.GetRGB("Pie" & i)
              i = i + 1
            Next
          Else                                                      'just copy the colors from XLMaster
            'collect the colors for each point in the SINGLE series in the MASTER pie chart
            i = 0
            For Each Ser In MChart.Chart.SeriesCollection
              For Each pnt In Ser.Points
                ReDim Preserve Color(i)
                Color(i) = pnt.Format.Fill.ForeColor.RGB
                i = i + 1
              Next 'point
            Next 'series
            'take that collection of colors and apply them to the CLINIC pie chart points
            i = 0
            For Each Ser In CChart.Chart.SeriesCollection
              For Each pnt In Ser.Points
                pnt.Format.Fill.ForeColor.RGB = Color(i)
                i = i + 1
              Next 'point
            Next 'series
          End If
        Else
          'get the series colors from the MASTER
          i = 0
          For Each Ser In MChart.Chart.SeriesCollection
            ReDim Preserve Color(i)
            Color(i) = Ser.Interior.Color
            i = i + 1
          Next 'series
          'assign them to the CLINIC
          i = 0
          For Each Ser In CChart.Chart.SeriesCollection
            Ser.Interior.Color = Color(i)
            i = i + 1
          Next 'series
        End If 'pie chart
      End If 'clinic chart = master chart
    Next 'clinic chart
  Next 'master chart
  Set ColorWheel = Nothing

End Sub

这是ProcessDataSheet()代码.这将根据工作表中嵌入的一个或多个SQL查询更新工作表上的数据.

Private Sub ProcessDataSheet(ByRef NewSheet As Excel.Worksheet, ByRef NewXLName As String)

Const InstCountRow As Integer = 1
Const InstCountCol As Integer = 2
Const InstDataCol As Integer = 2
Const InstCol As Integer = 3
Const ClinicNameParm As String = "{ClinicName}"
Const LikeClinicName As String = "{LikeClinicName}"
Const StartDateParm As String = "{StartDate}"
Const EndDateParm As String = "{EndDate}"
Const LocIDParm As String = "{ClinicLoc}"

Dim Data As New ADODB.Recordset
Dim InstCount As Integer
Dim SQLString As String
Dim Inst As Integer
Dim pt As Excel.PivotTable
Dim Rng As Excel.Range
Dim Formula As String
Dim SChar As Integer
Dim EChar As Integer
Dim Bracket As Integer
Dim TabName As String
Dim RowCol() As String

  'loop through all the instructions on the page and update the appropriate data tables
  InstCount = NewSheet.Cells(InstCountRow, InstCountCol)
  For Inst = 1 To InstCount
    RowCol = Split(NewSheet.Cells(InstCountRow + Inst, InstDataCol), ",")
    SQLString = NewSheet.Cells(InstCountRow + Inst, InstCol)
    SQLString = Replace(SQLString, """", "'")
    If InStr(1, SQLString, LikeClinicName) > 0 Then
      SQLString = Replace(SQLString, LikeClinicName, "'" & ClinicSystoc & "%'")
    Else
      SQLString = Replace(SQLString, ClinicNameParm, "'" & ClinicSystoc & "'")
    End If
    SQLString = Replace(SQLString, LocIDParm, "'" & ClinicLocID & "%'")
    SQLString = Replace(SQLString, StartDateParm, "#" & StartDate & "#")
    SQLString = Replace(SQLString, EndDateParm, "#" & EndDate & "#")
    Data.Open Source:=SQLString, ActiveConnection:=CurrentProject.Connection
    If Not Data.EOF And Not Data.BOF Then
      NewSheet.Cells(CInt(RowCol(0)), CInt(RowCol(1))).CopyFromRecordset Data
    End If
    Data.Close
  Next

  'search for all external sheet refrences and truncate them so it points to *this* worksheet
  Set Rng = NewSheet.Range(NewSheet.Cells.Address).Find(What:=XLMasterFileName, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False)
  While Not Rng Is Nothing
    Formula = Rng.Cells(1, 1).Formula
    If InStr(1, Formula, "'") > 0 Then
      SChar = InStr(1, Formula, "'")
      EChar = InStr(SChar + 1, Formula, "'")
      Bracket = InStr(1, Formula, "]")
      TabName = Mid(Formula, Bracket + 1, EChar - Bracket - 1)
      Rng.Replace What:=Mid(Formula, SChar, EChar - SChar + 1), replacement:=TabName, Lookat:=xlPart
    End If
    Set Rng = NewSheet.Range(NewSheet.Cells.Address).Find(What:=XLMasterFileName, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False)
  Wend
  Set Rng = Nothing

  'fix all the pivot table data sources so they point to *this* spreadsheet
  'TODO: add a filter in here to remove blanks
  'NOTE: do I want to add for all pivots, or only selected ones?
  For Each pt In NewSheet.PivotTables
    Formula = pt.PivotCache.SourceData
    Bracket = InStr(1, Formula, "!")
    Formula = Right(Formula, Len(Formula) - Bracket)
    pt.ChangePivotCache XLClinic.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Formula)
  Next

  SaveNewXL NewXLName         'yes, save the spreadsheet every single time so that the links in the PPT can be updated to point to it.  Sigh...

End Sub

UPDATE

根据R3uK的建议,我在UpdateChartsSub 的开头添加了一个调用,在这里:

  If Master.ChartObjects.Count > 0 Then
    Set ColorWheel = New ChartColors      'only do this if we need to
  End If
  For Each MChart In Master.ChartObjects
    If Not MChart.Chart.PivotLayout Is Nothing Then

      'Re-copy just the pivot chart from Master to Clinic
      CopyPivotChart PivotItemsList, MChart, CChart, Clinic

    End If

在CopyPivotChart这里:

Private Sub CopydPivotChart(ByVal PivotItemsList As PivotTableItems, ByVal MChart As Excel.ChartObject, ByRef CChart As Excel.ChartObject, ByRef Clinic As Worksheet)

Dim TChart As Excel.ChartObject

'Breakpoint 1
  For Each TChart In Clinic.ChartObjects
    If TChart.Name = MChart.Name Then
      TChart.Delete
    End If
  Next

  MChart.Chart.ChartArea.Copy
'Breakpoint 2
  Clinic.PasteSpecial Format:="Microsoft Office Drawing Object", Link:=False, DisplayAsIcon:=False
  Clinic.PasteSpecial Format:=2

End Sub

当我运行该代码时,我现在得到了

运行时错误'1004':对象'_Worksheet'的方法'PasteSpecial'失败

在接下来的一行Breakpoint 2.

现在,如果我跳过For Each循环Breakpoint 1(手动拖动循环下面的执行点),并从Worksheet手动删除图表Clinic,那么代码执行得很好.

Answer 1

我通过使用启用宏的 .XLTM模板作为实际模板解决了该问题！

我现在打开 .XLTM，删除特定客户报告不需要的工作表，而不是打开模板文件，然后将模板所需的工作表复制到新工作簿。这完全消除了复制表格、图表和图形的需要，并消除了尝试这样做所产生的所有错误。

这并没有具体解决如何复制数据透视图而不丢失其数据透视图的问题，但它解决了如何实现这一点的更大问题（我确实说过我愿意接受替代建议）。