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

 

[logandiana]

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.

 

[Gokhan Aycan]

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]

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.

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]

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]

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]

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

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]

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]

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.

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