VBA将多个Excel文件中的多个图表复制到单个Word文档中

Question

在这里潜伏很长时间。 我试图将多个Excel文件中的约350张图表（图表）复制到一个Word文档中。 我不是专家，但到目前为止，我已经设法打开一个特定的excel文件并将图表复制到Word文档中。

Sub copy_pic_excel()
Dim xlsobj_2 As Object
Dim xlsfile_chart As Object
Dim chart As Object

Set xlsobj_2 = CreateObject("Excel.Application")
xlsobj_2.Application.Visible = False
Set xlsfile_chart = xlsobj_2.Application.Workbooks.Open("C:\Users\Kiel\Desktop\chart.xls")

Set chart = xlsfile_chart.Charts("chart1")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

Set chart = xlsfile_chart.Charts("chart2")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

Set chart = xlsfile_chart.Charts("chart3")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

 Set chart = xlsfile_chart.Charts("chart4")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

Set chart = xlsfile_chart.Charts("chart5")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

Set chart = xlsfile_chart.Charts("chart6")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

Set chart = xlsfile_chart.Charts("chart7")
chart.Select
chart.ChartArea.Copy
With Selection
   .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False
End With

'clean up
Set xlsfile_chart = Nothing
xlsobj_2.Quit
Set xlsobj_2 = Nothing
End Sub

显然，这每次都是一个巨大的混乱和错误，但这仅适用于小型项目。

任何人都可以建议扩展它以从整个文件夹中为所有.xls文件中的所有图表获取图表吗？

Answer 1

要逐步浏览文件夹中的所有XLS文件，您需要使用DIR命令。 以下是其用法示例。 我将名称保存到单元格中，但是您可以简单地使用名称来传递给函数。 您将需要将路径名更改为所需的文件夹，但是有一个简单的快捷方式，将带有代码的主表保存在同一文件夹中，并使用Application.ActiveWorkbook.Path来获取当前路径名。

Sub Directory()
Dim strPath As String
Dim strFolderPath As String
Dim strFileName As String
Dim intRow As Integer
Dim intColumn As Integer

intRow = 1
intColumn = 1

strFolderPath = "h:\*.xls"
strFileName = Dir(strFolderPath)

Do
    Sheets("Main").Cells(intRow, intColumn) = strFileName  'test output to sheet
    Debug.Print strFileName 'test output to debug
    strFileName = Dir
    intRow = intRow + 1
Loop Until strFileName = ""
End Sub

然后，打开每个工作簿（不包含代码的工作簿），并使用“针对图表中的每个图表”循环浏览工作簿中的每个图表。

Dim myChart As Chart

For Each myChart In <Workbookname>.Charts
    Debug.Print myChart.Name 
    //or use the myChart object to pass to your code
Next