循环将图表从Excel复制到Word而不覆盖

Question

我想在循环的每次迭代中将散点平滑图表从 Excel 复制到 Word 作为图像。

上一张图片不断被下一张图片替换。

附加信息：

• 循环是从两个不同的工作表中绘制具有相同系列名称的多组数据。
• 需要以现有图表为模板

我的代码：

Sub create_Graph()
    Dim ws1, ws2 As Worksheet
    Dim searchRange, match As Range
    Dim firstMatch As Variant
    Dim currentValue As Variant
    Dim currentRow As Long
    Dim lastRow1, lastRow2 As Long
    Dim startRow1, startRow2 As Long
    Dim endRow1, endRow2 As Long
    Dim myChart As Chart
    Dim wApp As Object
    Dim wDoc As Object
    Dim wPara As Object
    
    'set the worksheet
    Set ws1 = Sh_before
    Set ws2 = Sh_after

    'On Error GoTo errorhandling
    
    'Create the word file
    Set wApp = CreateObject("Word.Application")
    wApp.Visible = True
    Set wDoc = wApp.Documents.Add
    
    'Find the last row
    lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    
    'initialize the variables
    startRow1 = 2
    currentValue = ws1.Cells(startRow1, 1).Value

    'Loop throught the row
    currentRow = 3
        
    For currentRow = 3 To lastRow1 + 1
    
        If ws1.Cells(currentRow, 1).Value <> ws1.Cells(startRow1, 1).Value Then
            endRow1 = currentRow - 1
            
            'Set search Range in after data
            Set searchRange = ws2.Range(ws2.Cells(1, 1), ws2.Cells(lastRow2, 1))
            Set match = searchRange.Find(what:=currentValue, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
            
            'Find the fist match
            If Not match Is Nothing Then
                firstMatch = match.Address
                startRow2 = match.Row
                
                'find the last match
                Do
                    Set match = searchRange.FindNext(match)
                    If match.Address = firstMatch Then Exit Do
                    endRow2 = match.Row
                Loop

                'Get the reference for the existing chart
                Set myChart = Sh_data.ChartObjects("PQ_Graph").Chart
                
                'Change the graph title
                myChart.ChartTitle.Text = currentValue
                
                'PQ, before
                myChart.SeriesCollection(1).XValues = ws1.Range(ws1.Cells(startRow1, 4), ws1.Cells(endRow1, 4))
                myChart.SeriesCollection(1).Values = ws1.Range(ws1.Cells(startRow1, 5), ws1.Cells(endRow1, 5))
                
                'PQ_After
                myChart.SeriesCollection(2).XValues = ws2.Range(ws2.Cells(startRow2, 4), ws2.Cells(endRow2, 4))
                myChart.SeriesCollection(2).Values = ws2.Range(ws2.Cells(startRow2, 5), ws2.Cells(endRow2, 5))
                
                'Current_Before
                myChart.SeriesCollection(3).XValues = ws1.Range(ws1.Cells(startRow1, 4), ws1.Cells(endRow1, 4))
                myChart.SeriesCollection(3).Values = ws1.Range(ws1.Cells(startRow1, 7), ws1.Cells(endRow1, 7))
                 
                'Current_After
                myChart.SeriesCollection(4).XValues = ws2.Range(ws2.Cells(startRow2, 4), ws2.Cells(endRow2, 4))
                myChart.SeriesCollection(4).Values = ws2.Range(ws2.Cells(startRow2, 7), ws2.Cells(endRow2, 7))
                            
                'Copy the graph and paste it as picture
                myChart.CopyPicture xlScreen, xlPicture
                wDoc.Range.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
                          
                'Pause for 1 sec
                Application.Wait Now + TimeValue("00:00:02")
                
                'Create a new page
                wApp.ActiveDocument.Sections.Add
                
                'Go to the new page
                wApp.Selection.Goto what:=wdGoToPage, which:=wdGoToNext
                
                'Clear the clipboard
                Application.CutCopyMode = False
                
            End If
            
            'Go to the next sample no.
            currentValue = ws1.Cells(currentRow, 1).Value
            startRow1 = currentRow

        End If
    Next currentRow
    
    MsgBox "Completed"

End Sub

• 我尝试在复制粘贴后在 Word 中插入分隔符
• 我尝试在代码中设置暂停
• 我尝试清除剪贴板。

我仍然可以通过Word窗口看到被替换的图像。

Answer 1

假设您希望将图表放置在文档的末尾。 替换：

            wDoc.Range.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
                      
            'Pause for 1 sec
            Application.Wait Now + TimeValue("00:00:02")
            
            'Create a new page
            wApp.ActiveDocument.Sections.Add
            
            'Go to the new page
            wApp.Selection.Goto what:=wdGoToPage, which:=wdGoToNext

与：

            wDoc.Characters.Last.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
                      
            'Pause for 1 sec
            Application.Wait Now + TimeValue("00:00:02")
            
            'Create a new page
            wDoc.Sections.Add