Script Efficiency

[MistakesWereMade]

Hi all.

I made a program that sorts through a master spread sheet with about 250k data entries. Unfortunately, it takes many hours to run... ANY help in improving the clock time would be tremendously insightful... but also helpful!

My script stores each unique entry name in a column as a vector, and then makes individual workbooks for each of these entries.
HOWEVER, the sorting does not stop here! Each unique entry has at least four categories associated with it, and therefore is sorted once more in finalized workbooks based on the categories.

Here is my all star analogy in case I'm being cryptic.
If I have a column of 4 different chili pepper names, but a single chili pepper may have two different places of origin, I want to sort all the data so that type A chili peppers from North America are in one workbook while type A (or B/C/D) chilli peppers from South America are in a separate workbook.

Thanks for any guidance!

Dim d As Object, c As Range, k, tmp As String, rng As Range, x As Long
Dim v As Object, c2 As Range, m, tmp2 As String, rng2 As Range, y As Long
   
Dim i As Long, ThisWb As Workbook, wbTemp As Workbook, ws As Worksheet
Dim td1 As String, td2 As String, td3 As String, td4 As String

Dim Master As Workbook, n As Long

Dim Z As Integer

Sub GetUniqueAndCount()
   
    ' Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    x = Cells(Rows.Count, 5).End(xlUp).Row
    Set rng = Range("E2:E" & x)
    Set d = CreateObject("scripting.dictionary")
    For Each c In rng
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c
   
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For Each k In d.keys
        Debug.Print k, d(k)
       
        Set ThisWb = ThisWorkbook
        Set wbTemp = Workbooks.Add
       
        On Error Resume Next
        For Each ws In wbTemp.Worksheets
            ws.Delete
        Next
        On Error GoTo 0
       
        For Each ws In ThisWb.Sheets
            ws.Copy After:=wbTemp.Sheets(1)
        Next
       
        wbTemp.Sheets(1).Delete
       
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        For i = Cells(Rows.Count, 5).End(xlUp).Row To 2 Step -1
       
            If Cells(i, 5).Value2 <> k Then
                wbTemp.Sheets(1).Rows(i).Delete
            End If
           
        Next i

        Call LineSort
       
    Next k
   
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Reset Macro Optimization Settings
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub

Sub LineSort()

y = wbTemp.Sheets(1).Cells(Rows.Count, 12).End(xlUp).Row
       
Set rng2 = wbTemp.Sheets(1).Range("L2:L" & y)
Set v = CreateObject("scripting.dictionary")
       
For Each c2 In rng2
    tmp2 = Trim(c2.Value)
    If Len(tmp2) > 0 Then v(tmp2) = v(tmp2) + 1
Next c2
       
Set Master = ThisWb
Set ThisWb = wbTemp
       
For Each m In v.keys
    Debug.Print m, v(m)
           
    Set wbTemp = Workbooks.Add
           
    On Error Resume Next
        For Each ws In wbTemp.Worksheets
        ws.Delete
    Next
    On Error GoTo 0
       
    For Each ws In ThisWb.Sheets
        ws.Copy After:=wbTemp.Sheets(1)
    Next
       
    wbTemp.Sheets(1).Delete
   
    Z = m
   
    For n = wbTemp.Sheets(1).Cells(Rows.Count, 12).End(xlUp).Row To 2 Step -1
        If wbTemp.Sheets(1).Cells(n, 12).Value <> Z Then
            wbTemp.Sheets(1).Rows(n).Delete
        End If
    Next n
   
    For i = 3 To wbTemp.Sheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count Step 1
        wbTemp.Sheets(1).Range("O" & i).Formula = "=TEXT(M" & i & "-M" & i - 1 & ", ""dd:hh:mm:ss"")"
    Next i
       
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        For i = 3 To wbTemp.Sheets(1).Range("E:E").Cells.SpecialCells(xlCellTypeConstants).Count Step 1
                td1 = Right(wbTemp.Sheets(1).Range("O" & i).Value, 2)
                td2 = Mid(wbTemp.Sheets(1).Range("O" & i).Value, 7, 2)
                td3 = Mid(wbTemp.Sheets(1).Range("O" & i).Value, 4, 2)
                td4 = Left(wbTemp.Sheets(1).Range("O" & i).Value, 2)
                td5 = td1 + td2 + td3 + td4
               
                If td5 <> 0 Then
                    wbTemp.Sheets(1).Range("P" & i).Formula = wbTemp.Sheets(1).Range("H" & i).Value / (td1 / 60 + td2 + td3 * 60 + td4 * 1440)
                Else
                    wbTemp.Sheets(1).Range("P" & i).Formula = 0
                End If
               
        Next i
       
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        wbTemp.SaveAs "C:\Users\hjh\Desktop\hjh\" & k & " Line " & Z & ".xlsx", 51
       
        DoEvents
        wbTemp.Close SaveChanges:=True
        DoEvents
           
Next m

ThisWb.Close SaveChanges:=False
Set ThisWb = Master

End Sub

 

[Fluff]

How many sheets do you have in the master workbook?
Also what is the sheet name you are running the dictionary on?

 

[MistakesWereMade]

Howdy Fluff.

I just have one sheet in all workbooks when the program is run.
These sheets are all named "Sheet_1"

 

[JoeMo]

I noticed in your code several For Each loops where you loop through a range of cells to load a dictionary yielding only the unique values in those cells. If you're looping through 250,000 cells in each of these For Each constructs, that is likely quite slow. You could consider replacing these by using variant arrays that store all the cell values in memory. Looping through memory is quite fast as no repeated access to your workbook is needed.
Here's an example that replaces the first For Each loop from your code where the Rng variable address is E2:Ex (where x is ~ 250,000??).

Sub LoopThruMemory()
Dim Varr As Variant, i As Long
x = Cells(Rows.Count, 5).End(xlUp).Row
    Set Rng = Range("E2:E" & x)
    Varr = Rng.Value
    Set d = CreateObject("scripting.dictionary")
    'In the For-Next block below, the dictionary will be loaded using the variant array
    'that's in memory, which should be much faster than visiting each cell on the worksheet sequentially
    For i = LBound(Varr, 1) To UBound(Varr, 1)
        tmp = Trim(Varr(i, 1))
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next i
    ' as an example, you could write the dictionary keys to say F2:F and the last cell required in F
    'like this
    Range("F2:F" & d.Count + 2 - 1).Value = Application.Transpose(d.keys)
End Sub

 

[Fluff]

How about this

Sub MistakesWereMade()
   Dim Ary As Variant, Kys As Variant, Ky As Variant
   Dim Dic As Object
   Dim i As Long
   Dim TmpE As String, TmpL As String
   Dim DelRng As Range
   
'     Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
   
   Set Dic = CreateObject("scripting.dictionary")
   
   With Sheets(1)
      Ary = .Range("E2:L" & .Range("E" & Rows.Count).End(xlUp).Row).Value2
   End With
   For i = 1 To UBound(Ary)
      TmpE = Trim(Ary(i, 1))
      TmpL = Trim(Ary(i, 8))
      If Len(TmpE) > 0 Then
         If Not Dic.exists(TmpE) Then Dic.Add TmpE, CreateObject("Scripting.dictionary")
         If Len(TmpL) > 0 Then Dic(TmpE).Item(TmpL) = Empty
      End If
   Next i
    
   For Each Kys In Dic.Keys
      For Each Ky In Dic(Kys).Keys
         ThisWorkbook.Sheets.Copy
         Set DelRng = Nothing
         With ActiveWorkbook.Sheets(1)
            .Range("A1").AutoFilter 5, "<>" & Kys
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
            .Range("A1").AutoFilter 12, "<>" & Ky
            .AutoFilter.Range.Offset(1).EntireRow.Delete
            .AutoFilterMode = False
            .Range("O3:O" & .Range("E" & Rows.Count).End(xlUp).Row).FormulaR1C1 = "=TEXT(RC13 -r[-1]c13, ""dd:hh:mm:ss"")"
         End With
      Next Ky
   Next Kys

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Reset Macro Optimization Settings
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
End Sub

It should create all the workbooks & put the formula in col O.
Could you check it's working ok before I do the rest.
NOTE
Ate the moment it does not save or close the workbooks.

 

[MistakesWereMade]

Hey Fluff.

So I tried out your code and it was definitely a huge improvement... If I recall, it improved the speed by over 2x. However, I realized that deleting undesired rows was the part taking waaaayyyy too long.
I took on a new strategy to use AutoFilter, copy the visible cells, and then paste to new workbook. Doing this twice would allow me to sort VERY quickly through all my data using my two specifications.
If I recall correctly, my original code ran a single k loop cycle of about 20 mins, yours could do it in 9, and AutoFilter could do it in about 2... Now I'm about to get over 600k data points and run my program. This will turn ugly, I'm sure of it. ?

Dim d As Object, c As Range, k, tmp As String, rng As Range, x As Long
Dim v As Object, c2 As Range, m, tmp2 As String, rng2 As Range, y As Long

Dim i As Long, ThisWb As Workbook, wbTemp As Workbook, ws As Worksheet
Dim td1 As String, td2 As String, td3 As String, td4 As String

Dim masterWb As Workbook, n As Long, copyRange As Range, lastRow As Long, src As Worksheet, tgt1 As Worksheet, wbTemp2 As Workbook, tgt2 As Worksheet

Dim Z As Variant

Sub MistakesWereMade()
  
    ' Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set masterWb = ThisWorkbook
    Set src = masterWb.Sheets(1)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    x = Cells(Rows.Count, 5).End(xlUp).Row
    Set rng = Range("E2:E" & x)
    Set d = CreateObject("scripting.dictionary")
    For Each c In rng
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c
  
    lastRow = src.Range("E" & src.Rows.Count).End(xlUp).Row
  
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For Each k In d.keys
    
        src.Range("A1").AutoFilter Field:=5, Criteria1:=k
        
        Set wbTemp1 = Workbooks.Add
        Set tgt1 = wbTemp1.Sheets(1)
        
        Set copyRange = src.Range("A1:P" & lastRow)
        copyRange.SpecialCells(xlCellTypeVisible).Copy tgt1.Range("A1")
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        y = tgt1.Cells(Rows.Count, 10).End(xlUp).Row
            
        Set rng2 = tgt1.Range("J2:J" & y)
        Set v = CreateObject("scripting.dictionary")
            
        For Each c2 In rng2
            tmp2 = Trim(c2.Value)
            If Len(tmp2) > 0 Then v(tmp2) = v(tmp2) + 1
        Next c2
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        For Each m In v.keys
        
        Z = m & ".00"
        lastRow = tgt1.Range("C" & tgt1.Rows.Count).End(xlUp).Row
        
        tgt1.Range("A1").AutoFilter Field:=10, Criteria1:=Z
        
        Set wbTemp2 = Workbooks.Add
        Set tgt2 = wbTemp2.Sheets(1)
        
        Set copyRange = tgt1.Range("A1:N" & lastRow)
        copyRange.SpecialCells(xlCellTypeVisible).Copy tgt2.Range("A1")
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        For i = 3 To tgt2.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count Step 1
            tgt2.Range("M" & i).Formula = "=TEXT(K" & i & "-K" & i - 1 & ", ""dd:hh:mm:ss"")"
        Next i
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        For i = 3 To tgt2.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count Step 1
                td1 = Right(tgt2.Range("M" & i).Value, 2)
                td2 = Mid(tgt2.Range("M" & i).Value, 7, 2)
                td3 = Mid(tgt2.Range("M" & i).Value, 4, 2)
                td4 = Left(tgt2.Range("M" & i).Value, 2)
                td5 = td1 + td2 + td3 + td4
                
                If td5 <> 0 Then
                    tgt2.Range("N" & i).Formula = tgt2.Range("F" & i).Value / (td1 / 60 + td2 + td3 * 60 + td4 * 1440)
                Else
                    tgt2.Range("N" & i).Formula = 0
                End If
                
        Next i
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        tgt2.Columns("A:N").AutoFit
        wbTemp2.SaveAs "C:\Users\asd\Desktop\asd\" & k & " Line " & Z & ".xlsx", 51
        
        DoEvents
        wbTemp2.Close SaveChanges:=True
        DoEvents
            
        Next m
    
        wbTemp1.Close SaveChanges:=False
        
        Exit Sub
    
    Next k
    
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[MistakesWereMade]

I noticed in your code several For Each loops where you loop through a range of cells to load a dictionary yielding only the unique values in those cells. If you're looping through 250,000 cells in each of these For Each constructs, that is likely quite slow. You could consider replacing these by using variant arrays that store all the cell values in memory. Looping through memory is quite fast as no repeated access to your workbook is needed.
Here's an example that replaces the first For Each loop from your code where the Rng variable address is E2:Ex (where x is ~ 250,000??).

Sub LoopThruMemory()
Dim Varr As Variant, i As Long
x = Cells(Rows.Count, 5).End(xlUp).Row
    Set Rng = Range("E2:E" & x)
    Varr = Rng.Value
    Set d = CreateObject("scripting.dictionary")
    'In the For-Next block below, the dictionary will be loaded using the variant array
    'that's in memory, which should be much faster than visiting each cell on the worksheet sequentially
    For i = LBound(Varr, 1) To UBound(Varr, 1)
        tmp = Trim(Varr(i, 1))
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next i
    ' as an example, you could write the dictionary keys to say F2:F and the last cell required in F
    'like this
    Range("F2:F" & d.Count + 2 - 1).Value = Application.Transpose(d.keys)
End Sub

Interesting! I will try to use this when running my largest data set. Thank you