Извлечение диаграмм из одной таблицы Excel в другую, изменение размера шрифта и правильное расположение с помощью VBA - PullRequest
Новая
       6

Извлечение диаграмм из одной таблицы Excel в другую, изменение размера шрифта и правильное расположение с помощью VBA

0 голосов
/ 28 февраля 2020

Я подумал сделать макрос, чтобы сделать перемещение / положение диаграммы немного проще, однако мой макрос в настоящее время довольно трудоемкий и медленный - я уверен, что это более эффективный способ сделать это!

Проблема - у меня есть 2 таблицы, графики и pptspdf. В таблице графиков, скажем, 10 диаграмм, а другая (plotspdf) пуста. Я хочу, чтобы макрос переместил несколько выбранных диаграмм (скажем, для аргументов 1, 3, 5 и 8) в другую электронную таблицу с помощью простой вставки копии. Затем я хочу изменить размер шрифта на 8 и формат (высота и ширина) каждой диаграммы до 7 см X 13 см. Наконец, я хочу переместить диаграммы так, чтобы они хорошо помещались на странице - например, диаграмма 1 перемещается в ячейку A1; Диаграмма 3 перемещена в ячейку G35, et c et c.

Это то, что у меня сейчас есть ... есть способ сделать этот код немного более аккуратным / более эффективным. Заранее спасибо. 

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

1 Ответ

0 голосов
/ 02 марта 2020

Этот код также проверяет, существует ли диаграмма, прежде чем пытаться ее скопировать 

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
...