Any way I can SIGNIFICANTLY speed up this portion of my code?

[logandiana]

I have a macro that does a bunch of stuff, but then towards the end, a big spreadsheet is broken up via auto-filter and saved with each file being named an account name.
The code works great, but is a lot slower than I would have hoped. Last night I had a big list and it had to create just under 1200 files. I knew it would take a bit, but it went almost 2 hours.
I only posted the portion of the code that is taking the longest, and yes, I do have stuff like screen updating, alerts, and events, disabled at the beginning.

Any other methods I could use?

For i = 2 To LR

vbs.UsedRange.AutoFilter 1, UNI.Range("B" & i).Value

Set NBK = Workbooks.Add
Set NST = NBK.Sheets(1)

vbs.UsedRange.SpecialCells(xlCellTypeVisible).Copy NST.Range("A1")

    NST.Range("M1") = "Data current as of: " & Date + Time
    NST.Columns("A:M").EntireColumn.AutoFit
    NST.Columns("H").ColumnWidth = 40
    NST.Range("H1").Font.Bold = True
    NST.Range("H1").HorizontalAlignment = xlCenter

NBK.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & UNI.Range("B" & i).Value & ".xlsx"

NBK.Close True

vbs.UsedRange.AutoFilter

Next i

 

[Gokhan Aycan]

"Advanced Filtering" is the fastest way to filter and copy afaik. Maybe you can just advanced filter to a single sheet and just copy it to new workbooks?
It is quite easy to implement too.

 

[logandiana]

So I tried Advanced Filtering and the time is improved only slightly. I did a sample test of 50 and the original autofilter method I used above took 130 seconds, while the 'advanced filtering' method below
took 121 seconds to output the same.
Perhaps I have the code wrong though since I don't use advance filter that often.

For i = 2 To LR

crit.Range("A2").Value = UNI.Cells(i, 2).Value

Set rgData = vbs.Range("A1").CurrentRegion

Set rgCriteria = crit.Range("A1").CurrentRegion

Set rgOutput = newsht.Range("A1").CurrentRegion

rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput

newsht.Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & ActiveSheet.Range("A2").Value & ".xlsx"

ActiveWorkbook.Close True

Next i

Is there anything else I can try?

 

[Gokhan Aycan]

With 1200 files almost 2 hours it is approx. 6 secs/file. With 50 files about 2.5 secs/file. I wonder if it would make a difference between the two in a longer run. It is already a significant improvement with these numbers (almost half the time).

If criteria is just a single cell, no need for CurrentRegion. Also, another thing would be for criteria:

Read them into an array and loop its members instead of reading values from the worksheet. Have to check if possible with Advanced Filtering though, hmmm...

 

[Gokhan Aycan]

A quick search doesn't look good with respect to criteria from a variable, however I got some other idea.

Instead of creating a new workbook every file.
1. You have your 2 workbooks
2. Filter on one and copy to other with Advanced Filter
3. SaveAs with a new name
4. After saving, rgOutput.ClearContents or perhaps .Cells.Delete

How does this sound like?

 

[Gokhan Aycan]

Sorry for this misleading info:

If criteria is just a single cell, no need for CurrentRegion.

You can get the right part of below assignment into an array though.
crit.Range("A2").Value = UNI.Cells(i, 2).Value

Also, if this value is the same as ActiveSheet.Range("A2").Value while SaveAs, then you can use the array member for that as well, which will save you from reading values from sheets.

 

[Gokhan Aycan]

I made some tests, just SaveAs a workbook. Here are a couple of results for 100 files. Numbers are in milliseconds, so approx. 4 files/sec.

A RamDrive and SSD is pretty much equal in time.

Are you using an SSD or HDD? Can make some difference there. If you have a HDD maybe try a RamDrive?

Private Sub Test_SaveAs()
    
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    
    Set wbSource = ThisWorkbook
    Set wbDest = Workbooks("000.xlsx")
    
    Dim DestPath As String
    DestPath = "D:\Test VBA\test saveas\"
    
    Dim i As Long
    
    Dim TestTimer As HighResTimer
    
    Set TestTimer = New HighResTimer
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    TestTimer.StartTimer
    
    For i = 1 To 100
        If i Mod 10 = 0 Then DoEvents
        wbDest.SaveAs DestPath & "test-" & i & ".xlsx"
        
    Next i
    
    Debug.Print "Timer (SaveAs SSD): " & TestTimer.Elapsed * 1000
    
    DestPath = "R:\Test\"
    
    TestTimer.ResetTimer
    
    For i = 1 To 100
        If i Mod 10 = 0 Then DoEvents
        wbDest.SaveAs DestPath & "test-" & i & ".xlsx"
        
    Next i
    
    Debug.Print "Timer (SaveAs RamDrive): " & TestTimer.Elapsed * 1000
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    Set wbDest = Nothing
    Set wbSource = Nothing
    
End Sub

I will make a long test while eating dinner. Will let you know the outcome.

 

[Gokhan Aycan]

With 1200 files still around 250ms/file or 4 files/sec. It took a while for explorer.exe to come back to life after code finished though

 

[logandiana]

I had been working on something like this on my own actually. I was able to shave off some time by just saving over the open workbook each time with the new filter results.

But I am new to arrays and still trying to figure this one out.
I feel like I am close, but maybe no.

LR1 = UNI.Cells(Rows.Count, 2).End(xlUp).Row
Dim arr as Variant
arr = UNI.Range("B1:B" & LR1)
                          
                                               
outpt.Copy

Set newwb = ActiveWorkbook
Set newsht = newwb.Sheets("Sheet1")

For i = LBound(arr, 1) To UBound(arr, 1)



Set rgData = vbs.Range("A1").CurrentRegion

Set rgCriteria = arr(i, 1)

Set rgOutput = newsht.Range("A1").CurrentRegion


rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput


newwb.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & newsht.Range("A2").Value & ".xlsx"

Next i

 

[Gokhan Aycan]

Don't worry about using an array just for this case. It will not make your day if it saves 40ms over 2400 sheet references. I did not save those results but (for 2400 iterations using for...next) if you assign a cell from another cell's Value it took 115ms. Value2, which doesn't copy source formatting is 100ms. Getting the value's into an array and assigning from it's members took 75ms. These things matter if the code reads from/writes to sheets millions of times or you have a very time sensitive task. However, you may have other places where it can speed up the code.

You can check Paul Kelly's array guide, very good guides there Excel VBA Array – The Complete Guide

The above code won't work because Advanced Filter criteria must be a range (I did look it up after my comment and already mentioned it won't work in a previous post).

Something like this:

For i = 2 To LR    ' or LBound (arr) to UBound (arr)

crit.Range("A2").Value = arr (i, 1)      ' right part changed

Set rgData = vbs.Range("A1").CurrentRegion

Set rgCriteria = crit.Range("A1").CurrentRegion

Set rgOutput = newsht.Range("A1").CurrentRegion

rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & arr (i, 1) & ".xlsx"      ' File name part changed

rgOutput.EntireRow.Delete   ' to prepare for next filter item

Next i