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

 

[offthelip]

Your code does multiple access to the various worksheets on every iteration of your code. This is always going to be slow. One of the main reasons that vBA is slow is because the time taken to access the worksheet is a relatively long time. So looking at the code you have got under the "else" bit which is the code that gets executed every time: the first counts the current region, this is unnecessary because you have just written a load of data to it so the new value of nlr is = the previous value of nlr + lr -7, this will get rid of one worksheet access.
To really speed this up though the only real way is to get rid of all the writing to the worksheet on every loop. If you know the maximum size of the data on any of the worksheets what you could do is defien a huge variant array, and go through a loop opening each of the files and copying the data to the variant array. You can then paste this back to a worksheet in one go (quite fast) and then process it to get rid of all the blank rows. this will be much faster than writing to a worksheet in a loop multiple times.

 

[DataBlake]

whats taking the most time is definitely copy and pasting and selecting, which as offthelip mentioned, accesses your workbooks a lot.
what you can do instead is write the data to an array and then have the array write to the sheet after everything is accomplished.
to my understanding of your code you just want to:

-open each file in a folder
-copy the first workbook sheet 1 from row 7 down
-copy rest of the workbooks sheet 1 from row 8 down
-paste every row from cumulative workbooks into one sheet?

if thats the case try something like this
I did not test this and you should definitely try this on copies of your data and not the real things

Sub tester()

    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


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


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


ReDim bigARRAY(1 To x)
Set mainfold = fso.GetFolder(Mac.Range("b3").Value)

     For j = 1 To UBound(bigARRAY)
        Set wb = Workbooks.Open(myfile.Path, UpdateLinks:=False, ReadOnly:=True)
            If x = 1 Then
                With wb.Sheets(1)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = ws.UsedRange.Columns.Count
                    bigARRAY(j) = .Range("A7:" & lr & lc).Value2
                End With
                wb.Close False
            Else
                With wb.Sheets(1)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = ws.UsedRange.Columns.Count
                    bigARRAY(j) = .Range("A8:" & lr & lc).Value2
                End With
                wb.Close False
            End If
     Next j

    

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
    Next y
        
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

the logic is basically to create an array that is as long as many files you have in mainfold
then for each j of the array you are loading the first sheet of the opened workbook
then once the array is completely loaded we open a new workbook
and for each y of the array you are writing that sheet to the new workbook

again not tested, most likely going to give you an error as i dont have the means to test right now.

 

[Mallesh23]

Hi offthelip and DataBlake,

First of all Thanks for your help, I tried your code on two files and my obervation is

I got error at
bigARRAY(j) = .Range("A8:" & lr & lc).Value2
so I replaced with bigARRAY(j) = .Range(.Cells(8, 1), .Cells(lr, lc)).Value2

2) bigARRAY(j) value is overwritting
3) loop is running 4 times for two input files of a folder

after finishing the loop
4) when I reached line Set nwbk = Workbooks.Add , value in bigArray is getting 0


you can create dummy xxx data, Data starts from 8 the Row and Columns are 70 .
I think we need to user Preserve in Array.

Sub tester()

    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


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

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

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

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

ReDim bigARRAY(1 To x)
'Set mainfold = fso.GetFolder(Mac.Range("b3").Value)
       
For Each myfile In mainfold.Files
     For j = 1 To UBound(bigARRAY)
        Set wb = Workbooks.Open(myfile.Path, UpdateLinks:=False, ReadOnly:=True)
               
                k = k + 1
            If k = 1 Then
                With wb.Sheets(repeat_sht)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    'bigARRAY(j) = .Range("A8:" & lr & lc).Value2  'Coming Error added below line
                    bigARRAY(j) = .Range(.Cells(8, 1), .Cells(lr, lc)).Value2  ' Replaced above line with below code
                End With
                wb.Close False
            Else
                With wb.Sheets(repeat_sht)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    'bigARRAY(j) = .Range("A8:" & lr & lc).Value2   'Macro was throwing error at this line
                    bigARRAY(j) = .Range(.Cells(9, 1), .Cells(lr, lc)).Value2  ' Added below line
                End With
                wb.Close False
            End If
     Next j

    Next myfile
   

Set nwbk = Workbooks.Add    'Value in bigArray is empty.
    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
    Next y
       
       
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[DataBlake]

you can create dummy xxx data, Data starts from 8 the Row and Columns are 70 .
I think we need to use Preserve in Array.

i will test and let you know, but what reference did you make for the fso as new filesystemobject?
and what values are in B3 and B6?

 

[DataBlake]

Sub tester()

    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


    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

ReDim bigARRAY(1 To x)
'Set mainfold = fso.GetFolder(Mac.Range("b3").Value)
       
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)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    'bigARRAY(j) = .Range("A8:" & lr & lc).Value2  'Coming Error added below line
                    bigARRAY(k) = .Range(.Cells(8, 1), .Cells(lr, lc)).Value2  ' Replaced above line with below code
                End With
                wb.Close False
            Else
                With wb.Sheets(repeat_sht)
                    lr = .Cells(Rows.Count, 1).End(xlUp).Row
                    lc = .UsedRange.Columns.Count
                    'bigARRAY(j) = .Range("A8:" & lr & lc).Value2   'Macro was throwing error at this line
                    bigARRAY(k) = .Range(.Cells(9, 1), .Cells(lr, lc)).Value2  ' Added below line
                End With
                wb.Close False
            End If


    Next myfile
   lr = 2

Set nwbk = Workbooks.Add    'Value in bigArray is empty.
    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
    Next y
       
       
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

this revision worked for me putting the folder name in B3 and sheet name in B6
i assume that your fso range needs the "mac" portion so just add that back.

 

[DataBlake]

tl:dr of why it wasnt working is because i had added a "for loop" that looped through the array and you added a loop for each file. These were interfering with each other so i just went and removed my for loop in favor of opening files your way. Also the last row code was off because i forgot to reset the value so it was pasting to the new sheet at the last row of the previous file (whoops). Fixed it though.

The reason the array shows as 0 to you, etc is because this is a 3d array not a 2d array. Each sheet is an array inside of an array (array inception if you will). So using preserve array syntax would not be good here as we are not adding the sheet to an existing array, but rather stuffing arrays inside of one big 3 dimensional array.

 

[Mallesh23]

tl:dr of why it wasnt working is because i had added a "for loop" that looped through the array and you added a loop for each file. These were interfering with each other so i just went and removed my for loop in favor of opening files your way. Also the last row code was off because i forgot to reset the value so it was pasting to the new sheet at the last row of the previous file (whoops). Fixed it though.

The reason the array shows as 0 to you, etc is because this is a 3d array not a 2d array. Each sheet is an array inside of an array (array inception if you will). So using preserve array syntax would not be good here as we are not adding the sheet to an existing array, but rather stuffing arrays inside of one big 3 dimensional array.

 

[Mallesh23]

Hi Datablake,

Your code is working fine, one small thing needs to added, Column one should contain Account Name,
we get the account name from input files sheets ie ws.Range("b3"), where account name is mentioned.

you will get an idea from first posts coding. but still your code is awsome !1

nwbk.Worksheets(1).Range("a1").Value = "Fund Name"
nwbk.Worksheets(1).Range("a2").Resize(lr - 7).Value = ws.Range("b3")


Regards,
mg

 

[DataBlake]

you will get an idea from first posts coding. but still your code is awsome !1

just change this line
nwbk.Sheets(1).Range("B" & lr).Resize(UBound(bigARRAY), UBound(bigARRAY, 2)).Value = bigARRAY
and then whatever method you prefer for adding the account name, etc

Glad i could help you find a solution