遍历目录中的所有xls文件，复制范围，并粘贴到docx文件？

我在一个目录中有大约500个Excel文件。 所有文件在第一张表（相同的大小）上有一个表。 我的客户希望他们都在一个字的文件。 我不是一个VBA专家，尝试使用我在网上find的代码。 我到目前为止已经遍历了目录中的所有文件。 它也select和复制特定范围。 但是，我如何获得转移到word文件？

这是我做的：

Sub LoopAllExcelFilesInFolder() Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xls" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) 'Loop through each xls files dir Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Select range and copy Range("G10:M25").Select Selection.Copy 'Save and Close Workbook wb.Close SaveChanges:=True 'Get next file name myFile = Dir DoEvents Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 

Answer 1

下面的代码来自这里，并调整到你提供的。 你应该通读链接的解释，因为它回答你的问题。 我对下面的代码做的唯一的补充是把一个计数器（ i ），所以你可以添加表单在文档中循环通过它们。

 Sub LoopAllExcelFilesInFolder() Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog Dim tbl As Excel.Range Dim WordApp As Word.Application Dim myDoc As Word.Document Dim WordTable As Word.Table Dim i As Long 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.xls" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) On Error Resume Next 'Is MS Word already opened? Set WordApp = GetObject(class:="Word.Application") 'Clear the error between errors Err.Clear 'If MS Word is not already open then open MS Word If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application") 'Handle if the Word Application is not found If Err.Number = 429 Then MsgBox "Microsoft Word could not be found, aborting." GoTo EndRoutine End If On Error GoTo 0 'Make MS Word Visible and Active WordApp.Visible = True WordApp.Activate 'Create a New Document Set myDoc = WordApp.Documents.Add 'Loop through each xls files dir i = 1 Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Assign range and Copy Set tbl = Range("G10:M25") tbl.Copy 'Paste Table into MS Word myDoc.Paragraphs(i).Range.PasteExcelTable _ LinkedToExcel:=False, _ WordFormatting:=False, _ RTF:=False 'Autofit Table so it fits inside Word Document Set WordTable = myDoc.Tables(i) WordTable.AutoFitBehavior (wdAutoFitWindow) i = i + 1 'Incrementing paragraph and table number 'Save and Close Workbook wb.Close SaveChanges:=True 'Get next file name myFile = Dir DoEvents Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub