将Excel图表复制为图片并粘贴到其他图纸中的范围

Question

我一直在尝试下面的代码以将图表复制为图片，并将其粘贴到另一个图纸中而不进行选择/激活。但它似乎并未将图片粘贴到该范围内：

Dim Range_DriverLookup As Range, RowCounter_DriverLookup As Long 
Dim Count_DeliveredServicesNumber As Long, Counter_DeliveredServicesNumber As Long 
Dim Cht_SitePotential As ChartObject 
Dim Cht_Top5 As ChartObject 
Dim Cht_RegionalPeerGroup As ChartObject 
Dim PvtTbl_SitePotential As PivotTable 
Dim PvtTbl_Top5 As PivotTable 
Dim PvtTbl_RegionalPeerGroup As PivotTable 
Dim Graph_PerformanceReport As Excel.Picture 

''''''''''''''''''''''''''''''''''''''''' 
' Assign ranges, pivottables and charts ' 
''''''''''''''''''''''''''''''''''''''''' 
Set Range_DriverLookup = ThisWorkbook.Worksheets(SheetDriverLookup.Name).ListObjects("DriverLookup").DataBodyRange 
Set PvtTbl_SitePotential = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableSitePotential") 
Set PvtTbl_Top5 = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableTop5") 
Set PvtTbl_RegionalPeerGroup = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).PivotTables("PivotTableRegionalPeerGroup") 
Set Cht_SitePotential = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartSitePotential") 
Set Cht_Top5 = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartTop5") 
Set Cht_RegionalPeerGroup = ThisWorkbook.Worksheets(SheetPerformanceReportLookup.Name).ChartObjects("ChartRegionalPeerGroup") 

''''''''''''''''''''''''''''''''''' 
' Initiate new performance report ' 
''''''''''''''''''''''''''''''''''' 
'// Clear previous graphs 
For Each Graph_PerformanceReport In ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Pictures 
    Graph_PerformanceReport.Delete 
Next Graph_PerformanceReport 
'// Clear previous sheet setup, and initiate new 
Stop 
With ThisWorkbook.Worksheets(SheetPerformanceReport.Name) 
    '/ Unhide rows in PerformanceReport 
    .Cells.EntireRow.Hidden = False 
    '/ Clear previous "table of content" 
    .Range("TableOfContent").ClearContents 
    '/ Reset pagebreaks and set for new frontpage 
    .ResetAllPageBreaks 
    .Rows(71).PageBreak = xlPageBreakManual 
End With 

'// Set filters on frontpage graph 
PvtTbl_SitePotential.ClearAllFilters 
PvtTbl_SitePotential.PivotFields("Serviceline").AutoSort Order:=xlDescending, Field:="Potential Savings (Yearly) " 
PvtTbl_SitePotential.PivotFields("Serviceline").ShowDetail = False 
PvtTbl_SitePotential.PivotFields("Site").PivotFilters.Add Type:=xlCaptionEquals, Value1:=ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("Site").Value 
PvtTbl_SitePotential.PivotFields("Serviceline").PivotFilters.Add _ 
Type:=xlValueIsGreaterThanOrEqualTo, DataField:=PvtTbl_SitePotential.PivotFields("Potential Savings (Yearly) "), Value1:=5000 

'// Create title for frontpage graph 
With Cht_SitePotential.Chart.ChartTitle 
     .Caption = ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("Site") & " - Yearly Potential on Service Level" 
End With 

'// Paste frontpagegraph to PerformanceReport 
With Cht_SitePotential.Chart 
    .ChartArea.Copy 
End With 
ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("D7:D7").PasteSpecial xlPasteValues 

使用较大部分代码进行编辑。

Answer 1

I'ts工作对我来说，当我模拟.Range("Frontpage_Graph")与"P1:P1"

ThisWorkbook.Worksheets(SheetPerformanceReport.Name).Range("P1:P1").PasteSpecial ppPasteEnhancedMetafile 

ppPasteEnhancedMetafile会给一个更好的分辨率图图片。

如果您使用范围像"P10:Z20"它将只使用P10作为图表图片的锚点。