excel - 将图表从一张纸复制到另一张纸到特定单元格。在继续下一个图表之前，更改图表 VBA excel 的 X 和 Y 边界

Question

所以我有将图表从一张纸复制到另一张纸的代码。这很好用——它会根据图表名称和所需的单元格迭代地执行它。

问题 - 我想在循环复制和粘贴下一个图表之前编辑图表的 X 和 Y 边界等 - 这可能吗？现在我已经设置了一个用户窗体（未显示），它要求输入 xmin、xmax、ymin 和 ymax 但我似乎想不出一种将它们连接在一起的方法......有什么想法吗？提前致谢。

Private Sub CopyPaste()

    Call stepinput
    Const H_MM = 70 ' 70 mm
    Const W_MM = 100 '98 mm
    Const FACTOR = 2.835 'convert Excel units to mm
    Const FONT_SIZE = 8

    Dim CHART_NAME As Variant, CHART_CELL As Variant
    CHART_NAME = Array("Chart 11", "Chart 16", "Chart 3", "Chart 4", "Chart 7", "Chart 8") '<~~~ Chart NAMES required
    CHART_CELL = Array("A8", "G8", "A22", "G22", "A38", "G38") '<~~~ Array length must match above Array length

    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
    Dim step_answer As Integer
    Dim s As Shape

    Set wb = ActiveWorkbook 'ThisWorkbook
    Set wsSource = wb.Sheets("plots") 'Source Sheet
    Set wsTarget = wb.Sheets("plotspdf") 'Destination sheet

    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 charts from Source to Target
        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

                ChangeXY.Show


                'ActiveSheet.PasteSpecial Format:=1
                Application.CutCopyMode = False
                count = count + 1
             End If
        Next

        ' format charts and convert to JPEG
        For Each chtObj In .ChartObjects
            'Change Textbox Size
            For Each s In chtObj.Chart.Shapes
            If s.Type = msoTextBox Then
                s.TextFrame2.TextRange.Font.Size = 8
            End If
        Next s
            'Debug.Print i, chtObj.Name   '
            chtObj.Height = H_MM * FACTOR
            chtObj.Width = W_MM * FACTOR
            chtObj.Chart.ChartArea.Font.Size = FONT_SIZE
            chtObj.Chart.ChartArea.Copy
            .Range("D8").Select
            ActiveSheet.PasteSpecial Format:=1
            chtObj.Chart.Parent.Delete
        Next chtObj

    End With
    MsgBox count & " charts copied", vbInformation, "Finished"

    step_answer = MsgBox("More steps?", vbQuestion + vbYesNo)
    If step_answer = vbYes Then
    'loop to beginning of program
    Call CopyPaste
    Else
    End If

End Sub

标签： excelvba

Answer 1

通过设置 ActiveChart 的 x 和 y 边界来解决，即 ActiveChart.xlValue（或 xlCategory，取决于您选择的那个）等于我的用户窗体的文本框。