VBA help to speed up Consolidation of data

[Mallesh23]

Hi Team,

Below is the macro I am using for colating data from all excel files,
I have 250 excel files in a Single Folder which I want to collate, This Macro works fast till 50 files,

Then Macro slows down,

is there is any other way to increase speed, using collection/Array/Recordset,
or Can you help me in existing code to increase speed. Thanks in advance!

Option Explicit
Sub Consolidate_All_workbook()
    Dim fso As New FileSystemObject
    Dim mainfold As Scripting.Folder
    Dim subfold As Scripting.Folder
    Dim myfile As Scripting.file
    Dim firstfile As String
    Dim Filename As String
    Dim ws As Worksheet
    Dim cnt As Integer
    Dim wb As Workbook
    Dim nwbk As Workbook
    Set nwbk = Workbooks.Add
    Dim nlr As Long
    Dim strSearch As String
    Dim lr As Long
    Dim lc As Long
    Dim t As Single
    t = Timer
    
    Dim repeat_sht As String
    repeat_sht = Mac.Range("b6").Value
   
    Dim countfile As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    On Error GoTo eh:
    
    Set mainfold = fso.GetFolder(Mac.Range("b3").Value)
        For Each myfile In mainfold.Files
                    cnt = cnt + 1
                    Set wb = Workbooks.Open(myfile.Path, UpdateLinks:=False, ReadOnly:=True)
                                    
                Set ws = wb.Worksheets(repeat_sht) '
 '                   If ws.AutoFilterMode = True Then ws.AutoFilterMode = False
'                    If ws.FilterMode = True Then ws.ShowAllData
                countfile = countfile + 1
                If cnt = 1 Then
                lc = ws.UsedRange.Columns.Count
                lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
                    ws.Range("a7").Resize(lr, lc).Copy '
                    nwbk.Worksheets(1).Range("B1").PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    nwbk.Worksheets(1).Range("a1").Value = "Fund Name"
                    nwbk.Worksheets(1).Range("a2").Resize(lr - 7).Value = ws.Range("b3")
                    wb.Close False
                Else
                    nlr = nwbk.Worksheets(1).Range("b1").CurrentRegion.Rows.Count + 1
                    lc = ws.UsedRange.Columns.Count
                    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
                    ws.Range("a8").Resize(lr, lc).Copy
                    nwbk.Worksheets(1).Range("B" & nlr).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    nwbk.Worksheets(1).Cells(nlr, 1).Resize(lr - 7).Value = ws.Range("b3")
                    wb.Close False
                End If
            
            countfile = countfile + 1
            
        Next myfile
    
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

    nwbk.Activate
ActiveSheet.Range("a1").Select
Application.CutCopyMode = False
    
    MsgBox "Macro Successful Total " & countfile & " Files Consolidated in " & Timer - t & "   .Seconds"


Exit Sub
   
    
eh:
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
MsgBox "Macro got stuck here for workbook " & wb.Name, vbInformation

End Sub

Thanks
mg

 

[Mallesh23]

Hi DataBlake and Team,

Below code works perfectly for Collating all the files.
But I want Small changes in it. I am unable to do that.

I want to store fund name in Column A of Consolidated Data.
My Fund_Name lies in InputData = wb.Sheets(repeat_sht).Range("B3").Value

Option Explicit
Sub Collate_Array()
    Dim wb As Workbook, nwbk As Workbook
    Dim fso As New FileSystemObject
    Dim mainfold As Scripting.Folder
    Dim subfold As Scripting.Folder
    Dim myfile As Scripting.file
    Dim lr As Long
    Dim bigARRAY As Variant
    Dim x As Long, j As Long, y As Long, k As Long
    Dim Fund_Name As String
    


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

Set mainfold = fso.GetFolder(Range("b3").Value)

    For Each myfile In mainfold.Files
        x = x + 1
    Next myfile

    Dim repeat_sht As String
    repeat_sht = Range("b6").Value
  
k = 0

Dim lc As Long
ReDim bigARRAY(1 To x)
       
For Each myfile In mainfold.Files
        Set wb = Workbooks.Open(myfile.Path, UpdateLinks:=False, ReadOnly:=True)
        
               
                k = k + 1
            If k = 1 Then
                With wb.Sheets(repeat_sht)
                    Fund_Name = .Range("B3").Value   'I Want to Copy this Fund Name
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    bigARRAY(k) = .Range(.Cells(8, 1), .Cells(lr, lc)).Value2
                End With
                wb.Close False
            Else
                With wb.Sheets(repeat_sht)
                    Fund_Name = .Range("B3").Value   'I Want to Copy this Fund Name
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    bigARRAY(k) = .Range(.Cells(9, 1), .Cells(lr, lc)).Value2  ' Added below line
                End With
                wb.Close False
            End If

    Next myfile
   lr = 1

Set nwbk = Workbooks.Add
   For y = 1 To UBound(bigARRAY)
        nwbk.Sheets(1).Range("A" & lr).Resize(UBound(bigARRAY(y)), UBound(bigARRAY(y), 2)).Value = bigARRAY(y)
        lr = nwbk.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Shift Data to Column B and Column A Should Consist Fund Names of each file.
    Next y
       
       
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
        
    MsgBox "Macro Successful"
End Sub

 

[JackDanIce]

Make a copy of your workbook, replace all of the code with below and try:

Sub Agg_Data()
           
    Dim s As Double: s = Timer
    Create_New_Workbook CollectData([B3].Value, [B6].Value)
    MsgBox "Finishing importing data" & vbCrLf & vbCrLf & "Run time: " & Round(Timer - s, 2), vbOKOnly + vbInformation, "Macro Finished"
   
End Sub

Private Function CollectData(ByRef path As String, ByRef sheetName As String) As Variant

    Dim fso As New FileSystemObject
    Dim f   As Scripting.file
    Dim x   As Long
    Dim k   As Long
    Dim a   As Variant
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .EnableEvents = False
    End With

    With fso.GetFolder(path)
        ReDim a(1 To .Files.Count, 1 To 2)
        For Each f In .Files
            x = x + 1
            With Workbooks.Open(f.path, False, True)
                With .Sheets(sheetName)
                    a(x, 1) = .[B3].Value
                    k = Application.Min(x, 1)
                    a(x, 2) = .Cells(8 + k, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).row - (7 - k), .Cells(8, .Columns.Count).End(xlToLeft).Column).Value2
                End With
                .Close
            End With
        Next f
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlAutomatic
        .EnableEvents = True
    End With

    CollectData = a: Erase a
End Function

Private Sub Create_New_Workbook(ByRef a As Variant)
   
    Dim x   As Long
    Dim k   As Long
    Dim LR  As Long
   
    Application.ScreenUpdating = False
   
    With Workbooks.Add
        With .Sheets(1)
            For x = LBound(a, 1) To UBound(a, 1)               
                LR = .Cells(.Rows.Count, 2).End(xlUp).Offset(1).row
                .Cells(LR, 2).Resize(UBound(a(x, 2), 1), UBound(a(x, 2), 2)).Value = a(x, 2)
                .Cells(LR, 1).Resize(UBound(a(x, 2), 1) - 2).Value = a(x, 1)
            Next x
            .[A1].EntireRow.Delete
        End With
    End With
   
    Application.ScreenUpdating = True
   
End Sub