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

logandiana

Board Regular
Joined
Feb 21, 2017
Messages
105
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?

VBA Code:
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
 

logandiana

Board Regular
Joined
Feb 21, 2017
Messages
105
I figured it out the same way you describe above. When I ran a test of 50 it was about the same time frame with the array version actually about a second or two slower overall.
The main portion that looks like it’s slower for me is the actual saving part. Even though I have screen updating and display alerts turned off, the screen still flickers some and a progress bar window shows up for each save even though some times it’s only for a split second. One thing that I will try though is to have it save to my own computer in a temp drive or something, rather than saving it to a folder out on our network shared drive.
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Gokhan Aycan

Active Member
Joined
Aug 8, 2021
Messages
396
Office Version
  1. 365
Platform
  1. Windows
One thing that I will try though is to have it save to my own computer in a temp drive or something, rather than saving it to a folder out on our network shared drive.
This will definitely improve the time. And if your computer has both an SSD and a HDD use the SSD.

For the flickering, maybe you can hide or minimize the sheets, but then it may introduce other issues while/if workbook/sheet is referenced as ActiveWorkbook/Sheet.
Regarding the save progress window, google "excel vba disable save progress bar" and the first result talks about it. Saving on a network drive looks like it.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,246
Office Version
  1. 365
Platform
  1. Windows
Certainly the saving of files is likely to be a significant issue but I think some other parts of the code can be sped up.
Clearly I do not know exactly what is in your original file or how big it is but for a test file with 10,000 rows & 10 columns of simple data with 100 workbooks to be created, the code below took approximately 23 seconds for me whereas the code from post #1, adapted as best I could & with screen updating off etc, took 53 seconds. So well over a 50% reduction in time.

A couple of comments though.
  • In an effort to help with speed, I made the assumption that your data is reasonably uniform so I have only done the column auto fit once.
  • My code also alters the order of data in the original workbook. If that is a problem for you then you could uncomment the three 'b' lines I have in the code with minimal impact on the overall execution time. This includes another assumption though - that your original workbook does not contain formulas that need to be retained.
  • I did not use LR so check that I have used the correct values to get the workbook names. That is sheet UNI cell B2 down to the last cell in col B with data.
If either of the above still cause issues, I think work-arounds are possible and maintain most of the gained speed.

Test with a copy of your workbook.

VBA Code:
Sub Create_Workbooks()
  Dim vbs As Worksheet, UNI As Worksheet, NST As Worksheet
  Dim NBK As Workbook
  Dim a As Variant ', b As Variant
  Dim d As Object
  Dim i As Long, k As Long
  Dim bStarted As Boolean

  Application.ScreenUpdating = False
  Set vbs = Sheets("Sheet1")
  Set UNI = Sheets("Sheet2")
  Set d = CreateObject("Scripting.Dictionary")
  Set NBK = Workbooks.Add
  Set NST = NBK.Sheets(1)
  With UNI
    a = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = Empty
  Next i
  vbs.UsedRange.Rows(1).Copy Destination:=NST.Range("A1")
  With NST
    .Columns("H").ColumnWidth = 40
    .Range("H1").Font.Bold = True
    .Range("H1").HorizontalAlignment = xlCenter
  End With
  With vbs.UsedRange
    '  b = .Value
    .Sort Key1:=.Columns(2), Header:=xlYes
    a = .Columns(2).Resize(.Rows.Count + 1, 1).Value
    i = 2
    Do Until i = UBound(a)
      If d.exists(a(i, 1)) Then
        k = i
        NST.UsedRange.Offset(1).Clear
        Do Until a(k + 1, 1) <> a(k, 1)
          k = k + 1
        Loop
        NST.Range("M1").Value = Now
        .Rows(i).Resize(k - i + 1).Copy Destination:=NST.Range("A2")
        If Not bStarted Then
          NST.UsedRange.Columns.AutoFit
          bStarted = True
        End If
        NBK.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & a(i, 1) & ".xlsx"
        i = k
      End If
      i = i + 1
    Loop
    NBK.Close True
    '  .Value = b
  End With
  Application.ScreenUpdating = True
End Sub
 

logandiana

Board Regular
Joined
Feb 21, 2017
Messages
105
Unable to get this to work with or with out the b commented out. The only thing it is doing on my end is creating 1 new workbook and adding the header line at the top with the correctly formatted cell H1.
Not sure what is supposed to be happening with the IF statement, but the code finds nothing to do so the next time it stops is at NBK.Close where a window comes up asking me where I want to save the 1 open workbook with the header.

Not sure if it matters, but the background here is this: I have a sheet, VBS, with 12,000+ lines of account data. Column A is the account number, columns B through I are other account related stuff (invoice#s, part#s, etc.). Sheet UNI, is where I have all the unique account numbers in column B with the duplicates removed, there are 1192 unique account numbers. The idea is for the macro to use the values in column B of UNI as criteria to filter on only the data for that account on VBS. Create a new worksheet with a header and columns A-I data on the sheet, then save it as the account number for the title of the .xlsx. So in the end I should have a folder with 1192 files. (I have a separate macro that will then go create emails for each account and attach their unique file that matches their account number).
In my testing I have reduced the number of unique accounts to 50 to get an idea of how much time I am saving.
 

Gokhan Aycan

Active Member
Joined
Aug 8, 2021
Messages
396
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Did you modify these lines? Do you have any Sheet1 and Sheet2 in the file?

Set vbs = Sheets("Sheet1")
Set UNI = Sheets("Sheet2")
to
Set vbs = Sheets("VBS")
Set UNI = Sheets("UNI")
 

logandiana

Board Regular
Joined
Feb 21, 2017
Messages
105
Yes I did change those lines. I stepped through the code and when it gets to IF it jumps to END IF and does nothing in between.

BUT in the meantime this morning I did change my code on post #10. And instead of pointing my files to be saved on the shared network drive I added a SPLIT FILES folder to

VBA Code:
tempfolderpath = Environ("Temp")

I did a test of 50 and it completed so quick I thought it must not have worked, BUT IT DID! Then I decided to open it up to the full number of accounts, and the 1200 or so that took 2 hours the other night, completed in just over 2 minutes! About 10 per second!! That's the speed I was looking for!
 

Gokhan Aycan

Active Member
Joined
Aug 8, 2021
Messages
396
Office Version
  1. 365
Platform
  1. Windows
Good job!

Just saving 1200 empty workbooks was 5 minutes for me :)

One thing you should be aware of is Environ() reads from the enviromental variables as set in System and User Variables. If they (although not very likely) somehow get deleted or tampered with, the code would fail.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,246
Office Version
  1. 365
Platform
  1. Windows
Column A is the account number, columns B through I are other account related stuff (invoice#s, part#s, etc.). Sheet UNI, is where I have all the unique account numbers in column B with the duplicates removed, there are 1192 unique account numbers.
My mistake - in reading your original code I mistakenly thought we were looking at column B in both sheets.

Give this a try (with your other modifications re saving location, worksheet names etc of course)
Hopefully you still have the same sample file so we can see if this makes any further change to the speed.

VBA Code:
Sub Create_Workbooks_v2()
  Dim vbs As Worksheet, UNI As Worksheet, NST As Worksheet
  Dim NBK As Workbook
  Dim a As Variant ', b As Variant
  Dim d As Object
  Dim i As Long, k As Long
  Dim bStarted As Boolean

  Application.ScreenUpdating = False
  Set vbs = Sheets("Sheet1")
  Set UNI = Sheets("Sheet2")
  Set d = CreateObject("Scripting.Dictionary")
  Set NBK = Workbooks.Add
  Set NST = NBK.Sheets(1)
  With UNI
    a = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = Empty
  Next i
  vbs.UsedRange.Rows(1).Copy Destination:=NST.Range("A1")
  With NST
    .Columns("H").ColumnWidth = 40
    .Range("H1").Font.Bold = True
    .Range("H1").HorizontalAlignment = xlCenter
  End With
  With vbs.UsedRange
    '  b = .Value
    .Sort Key1:=.Columns(1), Header:=xlYes
    a = .Columns(1).Resize(.Rows.Count + 1, 1).Value
    i = 2
    Do Until i = UBound(a)
      If d.exists(a(i, 1)) Then
        k = i
        NST.UsedRange.Offset(1).Clear
        Do Until a(k + 1, 1) <> a(k, 1)
          k = k + 1
        Loop
        NST.Range("M1").Value = Now
        .Rows(i).Resize(k - i + 1).Copy Destination:=NST.Range("A2")
        If Not bStarted Then
          NST.UsedRange.Columns.AutoFit
          bStarted = True
        End If
        NBK.SaveAs ThisWorkbook.Path & "\SPLIT FILES\" & a(i, 1) & ".xlsx"
        i = k
      End If
      i = i + 1
    Loop
    NBK.Close True
    '  .Value = b
  End With
  Application.ScreenUpdating = True
End Sub
 

Forum statistics

Threads
1,144,703
Messages
5,725,839
Members
422,646
Latest member
matgabgrp

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top