VBA多个excel文件中的多个图表复制到单个单词文档

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