VBA -打开范围中列出的几个文件，并复制/粘贴几个工作表中的数据

Question

我到处找都找不到合适的解决方案。

在我的源工作簿中，我有一个范围在工作表"基本";其中包含多个文件名。

例如范围A1:A25

但并非此范围内的每个单元格都包含文件名。有些将为空。

我需要一个宏，打开范围A1:A25中列出的所有文件，然后从这些文件中的sheet1复制范围A1:K500，然后将此数据粘贴到我的源工作簿到几个工作表。

源工作簿中的几个工作表分别命名为1,2,3,4,5等。

所以宏应该打开A1:A25范围中列出的第一个文件，并从工作簿中将工作表A1:K500范围中的数据从工作表1复制到工作表"1";(范围A1:K500)在我的源工作簿。然后打开第二个文件+相同的任务并粘贴到工作表"2"在源工作簿等..

谢谢你，并致以最良好的问候。M

Answer 1

好了，这是目前为止的内容:

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim wb2 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 Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(FileName:=myPath & myFile)
Set wb2 = ThisWorkbook
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
wb.Worksheets(1).Range("A1:W500").Copy

——比;这里是点，它需要粘贴复制的数据到我的工作簿的表1——比;之后，打开下一个外部工作簿，复制的数据将粘贴到我的工作簿的工作表2等。

'Save and Close Workbook
wb.Close SaveChanges:=True

'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
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