VBA Looping through excel files in selected directory - Copy data and paste in different sheets

Question

I'm looking to select a directory and then loop through each xlsm file within that directory. For each loop it should open the file, copy a range and paste into the current workbook under a specific sheet.

I.e. the first file will paste into sheet1 the second opened file will past into sheet 2, and so on.

I have some code, now I need help to get it to paste the rang into a sheets.count? or something like that. At the moment it just pastes into sheet 1 because that is static.

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

Place wb1.Sheets.Add Before:=Worksheets(Worksheets.Count) between the Copy and PasteSpecial lines. The command will set the new sheet as the active one so the PasteSpecial will now have to be to the ActiveSheet. — Amorpheuses

Jay Jay · Accepted Answer · 2017-04-25T07:58:53

Worked with this...

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

VBA Looping through excel files in selected directory - Copy data and paste in different sheets

1 Answers