使用VBA将图表从一个excel电子表格提取到另一个，更改字体大小并正确定位

Question

我本想制作一个宏，让图表移动/定位更容易，但我的宏目前相当艰巨和缓慢-我相信这是一种更有效的方法！

问题是——我有两个电子表格，plots和plotspdf。Plots电子表格有10个图表，而另一个(plotspdf(是空白的。我希望宏使用简单的复制粘贴将选定的几个图表(为了参数起见，让我们说1、3、5和8(移动到另一个电子表格中。然后我想将字体大小更改为8，并将每个图表的格式(高度和宽度(更改为7cm X 13cm。最后，我想重新定位图表，使它们很好地适应页面——例如，图表1正在移动到单元格A1；图表3移动到单元格G35等

这就是我目前拥有的。。。有没有办法让这个代码更整洁/更高效。提前谢谢。

Sub ArrangeCharts()
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2")).Select
ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2", "Chart 3")).Select
ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2", "Chart 3", "Chart 4")).Select
Selection.Copy
Sheets("plotspdf").Select
Range("A2").Select
ActiveSheet.Paste
Selection.ShapeRange.Height = 198.4251968504
Selection.ShapeRange.Width = 255.1181102362
Range("E7").Select
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveSheet.Shapes.Range(Array("Chart 4", "Chart 5")).Select
ActiveSheet.Shapes.Range(Array("Chart 4", "Chart 5", "Chart 6")).Select
Range("E4").Select
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveSheet.Shapes("Chart 4").TextFrame2.TextRange.Font.Size = 8
ActiveSheet.ChartObjects("Chart 5").Activate
ActiveSheet.Shapes("Chart 5").TextFrame2.TextRange.Font.Size = 8
ActiveSheet.ChartObjects("Chart 6").Activate
ActiveSheet.Shapes("Chart 6").TextFrame2.TextRange.Font.Size = 8
ActiveSheet.ChartObjects("Chart 7").Activate
ActiveSheet.Shapes("Chart 7").TextFrame2.TextRange.Font.Size = 8
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveSheet.Shapes("Chart 4").IncrementLeft 62
ActiveSheet.Shapes("Chart 4").IncrementTop 12
ActiveSheet.ChartObjects("Chart 5").Activate
ActiveChart.PlotArea.Select
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 5").IncrementLeft -125
ActiveSheet.Shapes("Chart 5").IncrementTop 228
ActiveSheet.ChartObjects("Chart 7").Activate
ActiveSheet.Shapes("Chart 7").IncrementLeft -269
ActiveSheet.Shapes("Chart 7").IncrementTop 174
ActiveSheet.ChartObjects("Chart 7").Activate
ActiveSheet.Shapes("Chart 7").IncrementLeft -48
ActiveSheet.Shapes("Chart 7").IncrementTop 16
End Sub

Answer 1

在尝试复制之前，此代码还会检查图表是否存在

Option Explicit
Sub arrangecharts()
Const H_MM = 70 ' 70 mm
Const W_MM = 130
Const FACTOR = 2.835
Const FONT_SIZE = 8
Dim CHART_NAME As Variant, CHART_CELL As Variant
CHART_NAME = Array("Chart 11", "Chart 3", "Chart 4", "Chart 7", "Chart 8")
CHART_CELL = Array("A2", "I2", "A17", "I17", "A32")
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Dim chtObj As ChartObject, dictCharts As Object
Dim msg As String, i As Integer, count As Integer
Set wb = ActiveWorkbook 'ThisWorkbook
Set wsSource = wb.Sheets("plots")
Set wsTarget = wb.Sheets("plotspdf")
Set dictCharts = CreateObject("Scripting.Dictionary")
With wsSource
For Each chtObj In .ChartObjects
dictCharts.Add chtObj.Name, chtObj.Index
msg = msg & vbCr & chtObj.Index & vbTab & chtObj.Name
Next
End With
MsgBox msg, vbInformation, "Charts on " & wsSource.Name
' check for charts
msg = ""
For i = 0 To UBound(CHART_NAME)
If Not dictCharts.exists(CHART_NAME(i)) Then
msg = msg & CHART_NAME(i) & vbCr
End If
Next
' confirm ignore errors
If Len(msg) > 0 Then
msg = "Charts not found" & vbCr & msg & "Continue ?"
If vbNo = MsgBox(msg, vbYesNo, "Charts not found") Then Exit Sub
End If
count = 0
wsTarget.Activate
With wsTarget
' copy
For i = 0 To UBound(CHART_NAME)
'Debug.Print CHART_NAME(i)
If dictCharts.exists(CHART_NAME(i)) Then
wsSource.ChartObjects(CHART_NAME(i)).Copy
.Range(CHART_CELL(i)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
count = count + 1
End If
Next
' format
For Each chtObj In .ChartObjects
'Debug.Print i, chtObj.Name   '
chtObj.HEIGHT = H_MM * FACTOR
chtObj.width = W_MM * FACTOR
chtObj.Chart.ChartArea.Font.Size = FONT_SIZE
Next
End With
MsgBox count & " charts copied", vbInformation, "Finished"
End Sub