VBA循环遍历选定目录中的excel文件 - 复制数据并粘贴到不同的工作表中

Question

我正在寻找一个目录，然后遍历该目录中的每个 xlsm 文件。对于每个循环，它应该打开文件，复制一个范围并粘贴到特定工作表下的当前工作簿中。

即第一个文件将粘贴到 sheet1，第二个打开的文件将粘贴到 sheet 2，依此类推。

我有一些代码，现在我需要帮助才能将响铃粘贴到 sheet.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