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

Question

我在一个目录中有大约500个Excel文件。所有文件在第一张纸上都有一张表（相同尺寸）。我的客户希望他们都在一个单词文件中。我不是一个VBA专家，尝试使用我在网上找到的代码。到目前为止，我已经遍历目录中的所有文件。它还会选择并复制特定范围。但是，如何将文件传输到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

下面是从here来源，并调整到您所提供的一个代码。你应该通读链接的解释，因为它回答你问的问题。下面我做的代码的唯一的加放一个计数器（i），这样你就可以在Word文档中，你通过它们添加表周期。

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