Скопируйте диаграммы с одного листа на другой в заданную ячейку c. Прежде чем перейти к следующему графику, измените границы X и Y графика VBA excel

Question

Итак, у меня есть код, который копирует диаграмму с одного листа на другой. Это работает нормально - итеративно, в зависимости от имени диаграммы и желаемой ячейки.

Проблема - я хочу отредактировать границы X и Y диаграммы до ее циклического копирования, чтобы скопировать и вставить следующую диаграмму и т. Д. c. - Это возможно? Прямо сейчас я настроил пользовательскую форму (не показана), которая запрашивает ввод для 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

Answer 1

Решено с помощью этого параметра, x и y границы ActiveChart, т.е. ActiveChart.xlValue (или xlCategory в зависимости от того, какой вы выбираете), равны текстовому полю для моей пользовательской формы.