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

Question

我想制作一个宏来使图表 moving/position 更容易一些，但是我的宏目前非常费力和缓慢 - 我相信这是一种更有效的方法！

问题 - 我有 2 个电子表格、绘图和 plotspdf。 Plots 电子表格有 10 个图表，另一个 (plotspdf) 是空白的。我希望宏使用简单的复制粘贴将 select 几个图表（为了参数的缘故，假设 1、3、5 和 8）移动到另一个电子表格。然后我想将字体大小更改为 8，将每个图表的格式（高度和宽度）更改为 7cm X 13cm。最后，我想重新定位图表，以便它们很好地适合页面 - 例如图表 1 正在移动到单元格 A1；图表 3 移动到单元格 G35 等

这就是我目前拥有的...有没有办法使这段代码 neater/more 更高效。提前谢谢你。

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

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

Extract Charts from one excel spreadsheet to another, change the font size and reposition correctly using VBA

excel

vba

excel-charts