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