• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Create new workbooks accelerate the code with large data

YasserKhalil

Well-Known Member
Hello everyone
I have a userform from which I would select some parameters so as to finally create new workbooks based on the selected items from listbox
The code works fine .. but as for the original data, it takes so much time ..

Code:
Private Sub cmdCreateWorkbooks_Click()
    Dim x, ws As Worksheet, i As Long, lr As Long

    If cbSheet.Value = "" Then MsgBox "You Have To Select Sheet", vbCritical: Exit Sub
    If cbHeader.Value = "" Then MsgBox "You Have To Select Header", vbCritical: Exit Sub
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        Set ws = ThisWorkbook.Worksheets(CStr(cbSheet))
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
       
        For i = 0 To lstParameters.ListCount - 1
            If lstParameters.Selected(i) Then
                ws.Copy
                With ActiveWorkbook.Sheets(1)
                    .Name = "Sheet1"
                    .Rows("1:3").Delete
                    x = Application.Match(cbHeader.Value, .Rows(1), 0)
                    If IsError(x) Then GoTo Skipper
                   
                        'With wsSheet
        With .ListObjects(1).DataBodyRange
            .AutoFilter
            .AutoFilter Field:=x, Criteria1:=CStr(lstParameters.List(i, 0))
            '.EntireRow.Delete
            '.AutoFilter
        End With
    'End With

'                   .Range("A1").AutoFilter Field:=x, Criteria1:="<>" & CStr(lstParameters.List(i, 0))
'
'                    On Error Resume Next
'                        .Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'                    On Error GoTo 0
'
'                    .AutoFilterMode = False
'                    If .FilterMode = True Then .ShowAllData

                    'Call DelFilterParam(ActiveWorkbook.Sheets(1), .ListObjects(1), x, CStr(lstParameters.List(i, 0)))
                   
                    Application.DisplayAlerts = False
                        .Parent.SaveAs txtPath & ws.Name & "-" & lstParameters.List(i, 0) & ".xlsx"
                    Application.DisplayAlerts = True
                    .Parent.Close False
                 End With
            End If
Skipper:
        Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Workbooks Created Successfully At " & txtPath, 64
End Sub



This code in the userform module (the userform name is "Settings")

Select the sheet 9100
Select the header CUSTNU
and in the listbox select some items and finally click "Create Workbooks" button

The code works fine for me ..
What I am seeking for is to make it faster ...?
Any ideas my friends

The thread is posted here too
https://www.excelforum.com/excel-pr...ooks-accelerate-the-code-with-large-data.html
 

Attachments

  • Sample.xlsm
    716.4 KB · Views: 5
Hi !​
Following your directions it needs just 4 seconds to create the 6 workbooks on an old laptop (i3), is it the same on your side ?​
Another point : when I open a workbook just created by your procedure​
- for example 9100-49462.xlsx but it's the same whatever the workbook -​
it contains all the data, the worksheet is just filtered on the CUSTNU #49462, is it normal ?​
 
In fact I would filter only one value for example 9100-49462.xlsx should contain only the CUSTNU #49462 and delete the other rows ..
The time is more a little for me (10 seconds on the sample) and in the original file it takes too long
 
Does it take too long with the same parameters to create only the same 6 workbooks or is it the same execution time ?​
Instead of deleting rows maybe a faster way is to create first the new workbook​
then to copy only the relevant rows just by filtering and copy or better via an advanced filter​
but the destination workbook must contain data as an Excel table (a VBA ListObject) or without ?​
 
Yes it took long time with the same parameters ..
Yes that is a good idea to create the workbook and copy the relevant rows but I need to keep the formatting as in the original file and also keep it in table format
 
So in this case a template worksheet with the table and just an empty row is the easy way to create new workbook …​
 
But I just see it's not the same layout between 9100 & 1700 worksheets,​
how many different layouts in the real workbook ?​
 
The folder by default does not exist on my side - as not on system drive - so first optimization to get the correct desktop folder :​
Code:
Private Sub UserForm_Initialize()
         Dim Ws As Worksheet
    For Each Ws In ThisWorkbook.Worksheets
          If Ws.Name <> "insruction" And Ws.Visible = xlSheetVisible Then cbSheet.AddItem Ws.Name
    Next
          txtPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Sub
Do you like it ? So thanks to click on bottom right Like !
 
According to the previous post another optimization to start to browse with the correct default folder :​
Code:
Private Sub cmdBrowse_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        .ButtonName = "Confirm"
        .InitialFileName = txtPath
        If .Show = -1 Then txtPath = .SelectedItems(1) & "\"
    End With
End Sub
You may Like it !​
 
Next code may be a bit quicker but if you need to keep exactly the source sheet layout​
just reverse your filter in your actual procedure in order to delete undesired rows …​
For the control message box you must first amend the Tag property of the 4 controls :​
  • Tag for the cbSheet combobox : Sheet
  • Tag for the cbHeader combobox : Header
  • Tag for the lstParameters listbox : at least a Parameter
  • Tag for the txtPath textbox : an existing Folder
Code:
Private Sub cmdCreateWorkbooks_Click()
         Dim Ct As Control, S, L&, Rg As Range, V, Z!
Z = Timer
    For Each Ct In Controls
        Select Case TypeName(Ct)
               Case "ComboBox", "TextBox"
                    If Ct = "" Then Exit For
               Case "ListBox"
                    ReDim S(Ct.ListCount - 1)
                    For L = 0 To UBound(S):  S(L) = IIf(Ct.Selected(L), Ct.List(L), False):  Next
                    S = Filter(S, False, False)
                    If UBound(S) < 0 Then Exit For
        End Select
    Next
    If Ct Is Nothing Then
        If Right(txtPath, 1) <> "\" Then txtPath = txtPath & "\"
        If Dir(txtPath, vbDirectory) = "" Then Set Ct = txtPath
    End If
    If Not Ct Is Nothing Then
        Ct.SetFocus
        MsgBox "You Have To Select " & Ct.Tag, vbExclamation, "Form Control"
        Set Ct = Nothing
        Exit Sub
    End If
             Set Rg = ThisWorkbook.Sheets(cbSheet.Text).ListObjects(1).Range
             Application.DisplayAlerts = False
             Application.ScreenUpdating = False
             Sheet1.[K1].Value2 = cbHeader
    For Each V In S
             Sheet1.[K2].Value2 = V
        With Workbooks.Add.Sheets(1)
            .Name = cbSheet & "-" & V
             Rg.AdvancedFilter xlFilterCopy, Sheet1.[K1:K2], .[A1]
            .UsedRange.Columns.AutoFit
            .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes).TableStyle = "TableStyleMedium28"
            .Parent.SaveAs txtPath & .Name, 51
            .Parent.Close False
        End With
    Next
             Set Rg = Nothing
             Sheet1.[K1:K2].Clear
             Application.DisplayAlerts = True
             Application.ScreenUpdating = True
Debug.Print Format(Timer - Z, "0.000s")
             MsgBox "Workbooks Created Successfully At " & txtPath, 64
End Sub
Do you like it ? So thanks to click on bottom right Like !​
 
That's really amazing. I have learned a lot of tricks from your magic code
And it is very faster comparing to mine. That's why I wanted you to have a look at this thread
Thank you very very much my tutor
 
Are you sastisfied with the result layout ?​
As I maybe have an idea to keep the original layout / formatting as it is but I didn't have time today to test it out as I was on the road …​
 
Yes the code is faster than mine... and I am satisfied
But I welcome any other ideas so as to learn something new
 
I will give it a try later or tomorrow and I'll revert here even if it fails …​
The idea is simple : copy only once the original worksheet so the original formatting is preserved and use an advanced filter​
for each parameter but it could be tricky to combine with the ListObject and not sure about the time execution …​
 
Maybe a tiny little faster but keeping the original formatting :​
Code:
Private Sub cmdCreateWorkbooks_Click()
         Dim Ct As Control, S, L&, Rg As Range, V, Z!
Z = Timer
    For Each Ct In Controls
        Select Case TypeName(Ct)
               Case "ComboBox", "TextBox"
                    If Ct = "" Then Exit For
               Case "ListBox"
                    ReDim S(Ct.ListCount - 1)
                    For L = 0 To UBound(S):  S(L) = IIf(Ct.Selected(L), Ct.List(L), False):  Next
                    S = Filter(S, False, False)
                    If UBound(S) < 0 Then Exit For
        End Select
    Next
    If Ct Is Nothing Then
        If Right(txtPath, 1) <> "\" Then txtPath = txtPath & "\"
        If Dir(txtPath, vbDirectory) = "" Then Set Ct = txtPath
    End If
    If Not Ct Is Nothing Then
        Ct.SetFocus
        MsgBox "You Have To Select " & Ct.Tag, vbExclamation, "Form Control"
        Set Ct = Nothing
        Exit Sub
    End If
        Set Rg = ThisWorkbook.Sheets(cbSheet.Text).ListObjects(1).Range
        Me.Hide
        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
        Sheet1.[K1].Value2 = cbHeader
        Rg.Parent.Copy
        ActiveSheet.Rows("1:3").Delete
    For Each V In S
        Sheet1.[K2].Value2 = V
        ActiveSheet.Name = cbSheet & "-" & V
        Rg.AdvancedFilter xlFilterCopy, Sheet1.[K1:K2], ActiveSheet.UsedRange.Rows(1)
        ActiveSheet.ListObjects(1).Resize ActiveSheet.[A1].CurrentRegion
        ActiveWorkbook.SaveAs txtPath & ActiveSheet.Name, 51
    Next
        Set Rg = Nothing
        ActiveWorkbook.Close False
        Sheet1.[K1:K2].Clear
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
Debug.Print Format(Timer - Z, "0.000s")
        MsgBox "Data Exported Successfully To " & txtPath, 64
        Me.Show
End Sub
Do you like it ? So thanks to click on bottom right Like !
 
Thank you very much my tutor. You are really amazing. The time is nearly the same in both versions
Best and Kind Regards
 
Back
Top