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,

Pure

EDIT: I am using Excel 2010

First/Original Code

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

Current Code

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

1 answer

  • answered 2018-10-15 15:09 AcsErno

    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.