VBA通​​過所選目錄中的excel文件循環 - 複製數據並粘貼到其他工作表中

Question

我正在尋找選擇一個目錄，然後循環訪問該目錄中的每個xlsm文件。對於每個循環，它應該打開文件，複製範圍並粘貼到當前工作簿下的特定工作表中。

I.e.第一個文件將粘貼到sheet1中，第二個打開的文件將粘貼到第2張表格中，依此類推。

我有一些代碼，現在我需要幫助才能將它粘貼到sheets.count中？或類似的東西。目前它只是粘貼到表單1中，因爲它是靜態的。

Sub Test() 


Dim wb As Workbook, wb1 As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 

Set wb1 = Workbooks(ThisWorkbook.Name) 


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 = "*.xlsm" 

'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) 

'Ensure Workbook has opened before moving on to next line of code 
    DoEvents 

'Copy data from opened workbook 
    wb.Sheets("HI Sub-segment split").Range("A1:Z1").Copy 

'Paste data into destination workbook 
    wb1.Sheet(1).Range("A1:Z1").PasteSpecial xlPasteValues 

'Close Workbook 
    wb.Close 

'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 "Import Complete!" 

ResetSettings: 

Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub 

Answer 1

與這個工作...

Sub Testing() 

' 
' 
' 

Dim wb As Workbook, wb1 As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 
Dim loop_ctr As Integer 

Set wb1 = Workbooks(ThisWorkbook.Name) 
loop_ctr = 1 


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) 

'Ensure Workbook has opened before moving on to next line of code 
    DoEvents 

'Copy data from opened workbook 
    wb.Sheets("Sheet1").Range("A1:B2").Copy 

'Paste data into destination workbook 
    wb1.Sheets(loop_ctr).Range("A1:B2").PasteSpecial xlPasteValues 

'Close Workbook 
    wb.Close 

'Ensure Workbook has closed before moving on to next line of code 
    DoEvents 

'Get next file name 
    myFile = Dir 

'Update loop_ctr value 
    loop_ctr = loop_ctr + 1 
Loop 

'Message Box when tasks are completed 
MsgBox "Import Complete!" 

ResetSettings: 

Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 

End Sub