VBA code that loops through a folder and goes into each different excel file to the same sheet and copies the same range
I am trying to make a working VBA code that loops through a folder and goes into each excel file to the same sheet and copies the same range there to another excel file!
I had a working code (see below) but somehow it was not displaying the copy paste correctly (e.g. was showing 1,2479 as 12.479). I could not solve this so I looked for a new code and found and enhanced one (see below).
However, for just 9 files, this code runs for over 3 minutes! The final folder would have around 50 files, so I am a bit worried that excel won't be able to handle it.
I read a lot about not using .select, but I believe I am not doing that.
Does anyone have an idea to improve my code/shorten the duration? Your help is greatly appreciated. It seems such an easy thing to do (it copies always from the same sheet name and same range from each file in a folder!), yet it seems the work for the pc is quite heavy?
thank you so much,
EDIT: I am using Excel 2010
Sub LoopThroughDirectory() Dim MyFile As String Dim erow Dim Filepath As String 'Setting the right folder where the cartographies are Filepath = "C:\Users\xxx\OneDrive - xxx\Testexcel\" MyFile = Dir(Filepath) Application.ScreenUpdating = 0 Application.DisplayAlerts = 0 'Application.DecimalSeparator = "," 'Application.ThousandsSeparator = "." 'Application.UseSystemSeparators = False Do While Len(MyFile) > 0 'If MyFile = "zmaster.xlsm" Then 'Exit Sub 'End If 'Open all the workbook Workbooks.Open (Filepath & MyFile) 'Activate the right worksheet in the cartography file Worksheets("xxxxxx").Activate 'Highlight the range of cells we want to copy Range("E2:H2").Copy ActiveWorkbook.Close 'Add the copied cells to our sheet in the master file Worksheets("xxxxxx").Activate erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row ActiveSheet.Range(Cells(erow, 1), Cells(erow, 4)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlPasteSpecialOperationNone MyFile = Dir Loop 'Application.UseSystemSeparators = True End Sub
Sub Merge2MultiSheets() Dim xRg As Range Dim xSelItem As Variant Dim FileDlg As FileDialog Dim FileName, Standalone, Range2copy As String Dim Cartography As Workbook Dim TargetSheet As Worksheet On Error Resume Next Application.DisplayAlerts = False 'Optimize Code Call OptimizeCode_Begin 'Give the name of the sheet of cartography where data should be gathered Standalone = "xxxxxxxx" 'Say the range of the data to be copied from the sheet Range2copy = "E2:H2" Set Workbook = ThisWorkbook Set TargetSheet = Workbook.Sheets("Consolidated Cartography") 'Ask in pop-up where the folder is located with the excel files to update Set FileDlg = Application.FileDialog(msoFileDialogFolderPicker) With FileDlg If .Show = -1 Then xSelItem = .SelectedItems.Item(1) FileName = Dir(xSelItem & "\*.xls*", vbNormal) If FileName = "" Then Exit Sub Do Until FileName = "" 'Open the first file in the folder Set Cartography = Workbooks.Open(xSelItem & "\" & FileName) 'Open the right active sheet with data to be copied and put range into xRg Set xRg = Cartography.Worksheets(Standalone).Range(Range2copy) 'Copy xRg to the TargetSheet at location starting at A250, go up to last row with data then one down xRg.Copy TargetSheet.Range("A250").End(xlUp).Offset(1, 0) FileName = Dir() Cartography.Close Loop End If End With Application.DisplayAlerts = True Application.EnableEvents = True Application.ScreenUpdating = True 'Optimize Code Call OptimizeCode_End End Sub
I found this on the internet and it explained it does try to make your code faster by disabling some events and triggers.
Sub OptimizeCode_Begin() Application.ScreenUpdating = False EventState = Application.EnableEvents Application.EnableEvents = False CalcState = Application.Calculation Application.Calculation = xlCalculationManual PageBreakState = ActiveSheet.DisplayPageBreaks ActiveSheet.DisplayPageBreaks = False End Sub Sub OptimizeCode_End() ActiveSheet.DisplayPageBreaks = PageBreakState Application.Calculation = CalcState Application.EnableEvents = EventState Application.ScreenUpdating = True End Sub
A bit of speed improvement can be gained by counting the target rows instead of finding them in every loop. So in the initialisation phase (out of loop):
Dim iTrgRow As Long iTrgRow = TargetSheet.Range("A250").End(xlUp).Offset(1, 0).Row
Then in the loop:
Cartography.Worksheets(Standalone).Range(Range2copy).Copy Destination:=TargetSheet.Cells(iTrgRow, 1) iTrgRow = iTrgRow + 1
This will paste the copy buffer to column A, iTrgRow. It's OK as long as you copy one row of data.
For OptimizeCode collection: I agree with the comments above. Yet, you can turn off DisplayPageBreaks, Calculation, EnableEvents, ScreenUpdating, but I would leave DisplayAlerts on.