Hello Professionals,
I need your advise regarding enhancing the current macro.
Currently I have the below code (recursive method) to copy contents of the excel files from the a set folder only as shown below. But I am trying to create a non recursive method to copy the contents on the all the excel files from folders and subfolders. I am struggling to figure it out although I have reffered to many other links.
More about the macro workbook. It has a sheet named "macro" with macro button and two other sheets as "XXX" and "YYY". Currently in a folder it is opening all files which has two sheets "EXCP-701" and "EXCP-703" and copying its contents to the macro work book in sheets "XXX" and "YYY" respectively.
I am sure there is genious and quicker way of doing this. Could you kindly help me
Sub CombineData()
Dim oWbk As Workbook
Dim uRng, rToCopy, rNextCl As Range
Dim lCount As Long
Dim sPath, sFil, As String
Sheets("Macro").Select
On Error GoTo exithandler
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
sPath = .SelectedItems(1)
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
ChDir sPath
sFil = Dir("*.xls*")
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
With ThisWorkbook.Worksheets("XXX")
Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil) 'opens the file
Worksheets("excp-701").Activate
Set rToCopy = oWbk.Worksheets("EXCP-701").Range(Cells(8, 1), Cells(50000, 18))
Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
rToCopy.Copy rNextCl
With ThisWorkbook.Worksheets("YYY")
Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)
Worksheets("excp-703").Activate
Set rToCopy = oWbk.Worksheets("EXCP-703").Range(Cells(8, 1), Cells(50000, 18))
Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
rToCopy.Copy rNextCl
End With
End With
oWbk.Close False
sFil = Dir
Loop
exithandler:
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
I need your advise regarding enhancing the current macro.
Currently I have the below code (recursive method) to copy contents of the excel files from the a set folder only as shown below. But I am trying to create a non recursive method to copy the contents on the all the excel files from folders and subfolders. I am struggling to figure it out although I have reffered to many other links.
More about the macro workbook. It has a sheet named "macro" with macro button and two other sheets as "XXX" and "YYY". Currently in a folder it is opening all files which has two sheets "EXCP-701" and "EXCP-703" and copying its contents to the macro work book in sheets "XXX" and "YYY" respectively.
I am sure there is genious and quicker way of doing this. Could you kindly help me
Sub CombineData()
Dim oWbk As Workbook
Dim uRng, rToCopy, rNextCl As Range
Dim lCount As Long
Dim sPath, sFil, As String
Sheets("Macro").Select
On Error GoTo exithandler
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
sPath = .SelectedItems(1)
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
ChDir sPath
sFil = Dir("*.xls*")
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
With ThisWorkbook.Worksheets("XXX")
Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil) 'opens the file
Worksheets("excp-701").Activate
Set rToCopy = oWbk.Worksheets("EXCP-701").Range(Cells(8, 1), Cells(50000, 18))
Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
rToCopy.Copy rNextCl
With ThisWorkbook.Worksheets("YYY")
Set oWbk = Workbooks.Open(sPath & Application.PathSeparator & sFil)
Worksheets("excp-703").Activate
Set rToCopy = oWbk.Worksheets("EXCP-703").Range(Cells(8, 1), Cells(50000, 18))
Set rNextCl = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
rToCopy.Copy rNextCl
End With
End With
oWbk.Close False
sFil = Dir
Loop
exithandler:
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
