Question

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

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

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

问题分为三部分：

我可以阻止数据透视图转换为副本中的常规图表吗？即我错过了.Copy的标志/设置吗？
如果没有，我可以通过cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable的某些内容再次将图表更新为数据透视图吗？
如果没有其中任何一个，在复制的工作表中从头开始创建数据透视图的最佳方法是什么？

注意：

这些是标准的Excel数据透视表，我没有使用PowerPivot。不过，我对此持开放态度，如果能解决这个问题的话。 刚刚在PowerPivot上做了一点阅读，我认为它不会对我有所帮助，但是，我再次接受建议。

响应Jens'评论，原始数据和数据透视表位于一张工作表上，而数据透视图图表位于第二张工作表上。< / LI>

这是代码。它适用于所有，除了复制具有完整数据透视图的工作表作为数据透视图。

  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

更新

根据R3uK's suggestion，我在UpdateCharts Sub的开头添加了一个调用，在这里：

  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'：object'_Worksheet'的方法'PasteSpecial'失败

在Breakpoint 2之后的一行。

现在，如果我在For Each跳过Breakpoint 1循环（手动拖动循环下面的执行点），并从工作表Clinic手动删除图表，那么代码只执行细

Answer 1

1。在我复制数据透视表的简陋经历中，我没有复制工作表而是图表：

Sheets("Graph1").ActiveChart.ChartArea.Copy
ActiveSheet.PasteSpecial Format:="Objet Dessin Microsoft Office", _
    Link:=True, DisplayAsIcon:=False

您是否尝试创建空白页并将图表粘贴到其中？ 您可能需要更改使用法语的格式，但这应该可以解决问题！

2。没有头绪......

3. 为了从头开始创建数据透视表，我没有任何神奇的技巧，但我将其用作模板：

Sub Create_DCT(ByVal Source_Table_Name As String, ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)


    DeleteAndAddSheet DCT_Sheet_Name

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
        SourceData:=Source_Table_Name, _
        Version:=xlPivotTableVersion14). _
        CreatePivotTable _
        TableDestination:=DCT_Sheet_Name & "!R3C1", _
        TableName:=DCT_Name, _
        DefaultVersion:=xlPivotTableVersion14


End Sub

Sub Add_Fields_DCT(ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)
    Dim Ws As Worksheet
    Set Ws = Worksheets(DCT_Sheet_Name)

    'Organized filters
    With Ws.PivotTables(DCT_Name).PivotFields("Cluster")
        .Orientation = xlPageField
        .Position = 1
    End With
    With Ws.PivotTables(DCT_Name).PivotFields("Region")
        .Orientation = xlPageField
        .Position = 2
    End With
    With Ws.PivotTables(DCT_Name).PivotFields("Account")
        .Orientation = xlPageField
        .Position = 3

    'Organized rows
    With Ws.PivotTables(DCT_Name).PivotFields("Family")
        .Orientation = xlRowField
        .Position = 1
    End With
    With Ws.PivotTables(DCT_Name).PivotFields("Sub_family")
        .Orientation = xlRowField
        .Position = 2
    End With
    With Ws.PivotTables(DCT_Name).PivotFields("Invoice_Country")
        .Orientation = xlRowField
        .Position = 3
    End With
    With Ws.PivotTables(DCT_Name).PivotFields("Product")
        .Orientation = xlRowField
        .Position = 4
    End With

    'Columns : none
'    With Ws.PivotTables(DCT_Name).PivotFields("Family")
'        .Orientation = xlColumnField
'        .Position = 1
'    End With


'Data fields (adding, modifying, formatting and compacting)
    'Data fiels : Adding
    'With Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name)
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Total Qty", xlSum
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Avg Qty", xlAverage
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Qty of Orders", xlCount
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("TotalAmountEUR"), "TO (€)", xlSum
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("UPL"), "Avg UPL", xlAverage
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Avg Discount", xlAverage
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Min Discount", xlMin
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Max Discount", xlMax
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Min PVU", xlMin
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Max PVU", xlMax
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-PRI)/PVU"), "Gross Margin", xlAverage
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-TC)/PVU"), "Net Margin", xlAverage
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-PRI"), "Gross Profit (€)", xlSum
        Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-TC"), "Net Profit (€)", xlSum
    'End With

    'Data fiels : Modifying
'    With Ws.PivotTables(DCT_Name).PivotFields("Somme de Quantity")
'        .Caption = "Moyenne de Quantity"
'        .Function = xlAverage
'    End With



    'Data formatting
    With ActiveSheet.PivotTables(DCT_Name)
        .PivotFields("Total Qty").NumberFormat = "# ##0"
        .PivotFields("Avg Qty").NumberFormat = "# ##0,#"
        .PivotFields("Qty of Orders").NumberFormat = "# ##0"
        .PivotFields("TO (€)").NumberFormat = "# ##0 €"
        .PivotFields("Avg UPL").NumberFormat = "# ##0 €"
        .PivotFields("Avg Discount").NumberFormat = "0,0%"
        .PivotFields("Min Discount").NumberFormat = "0,0%"
        .PivotFields("Max Discount").NumberFormat = "0,0%"
        .PivotFields("Min PVU").NumberFormat = "# ##0 €"
        .PivotFields("Max PVU").NumberFormat = "# ##0 €"
        .PivotFields("Gross Margin").NumberFormat = "0,0%"
        .PivotFields("Net Margin").NumberFormat = "0,0%"
        .PivotFields("Gross Profit (€)").NumberFormat = "# ##0 €"
        .PivotFields("Net Profit (€)").NumberFormat = "# ##0 €"
    End With


'Compact row fields to minimum
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Sub_family").PivotItems
    PivIt.DrillTo "Invoice_Country"
Next PivIt

For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
    PivIt.DrillTo "Sub_family"
Next PivIt

For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
    PivIt.DrillTo "Family"
Next PivIt

End Sub

我的自定义功能DeleteAndAddSheet：

Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet

For Each aShe In Sheets
    If aShe.Name <> SheetName Then
    Else
        Application.DisplayAlerts = False
        aShe.Delete
        Application.DisplayAlerts = True
        Exit For
    End If
Next aShe

Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName

Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count)

End Function

希望它会对你有所帮助！

Answer 2

我建议创建一个链接到源数据表的第二个工作簿，然后在第二个工作表中创建匹配的数据透视表（两者基本上都使用相同的数据填充） - 我不确定下一个点，客户需要有图表的链接版本，还是纯粹用于自动报告？

如果是自动报告，那么我建议使用您当前的工作簿完全建议一种新方法 - 创建一个宏，以便在需要的时间，每日/每周/每月等时间运行并发送图表（来自您选择的工作表）作为PDF格式 - 如果需要，我有一些示例代码:)

Answer 3

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

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

这并没有专门解决如何复制数据透视表而不会失去其透视图的问题，但它解决了如何实现这一目标的更大图片问题（我说过我对备选建议持开放态度。）

Answer 4

如果复印带有数据的工作表和带有链接到该数据的图表的工作表，则复制的图表将不会链接到复制工作表上的数据，除非在一次操作中将工作表复制在一起。看起来您的代码首先使用数据透视表复制工作表，然后单独使用图表复制工作表（图表工作表或带有嵌入图表的工作表，并不重要）。图表丢失了与原始工作簿中数据透视表的链接，并成为具有硬编码值的常规图表。

重写代码以在一次操作中复制两张纸。然后在新工作簿中调整数据透视表和图表。

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

问题分为三部分：

4 个答案: