Code optimization required - run all processes in memory before placing result to worksheet

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,728
Office Version
2016
Platform
Windows
I need to get these codes run in memory for the various processes, before placing the result onto the sheet instead on interacting with the sheet for all the events. As my data grows, it seems to be slowing down my codes.

This post was inspired by @DanteAmor solution at:

Any of them that I get solution for, I will really appreciate that. I am working on effective ways to run my scripts faster by using better optimization techniques. Thanks in advance for taking the time, pain and effort to read this.

Script #1
Code:
Sub RankIt()
    Dim dicSection As Object, vItem, wsData As Worksheet, vSection
    Dim rScore As Range, rCell As Range, Score, Rnk#, lastrow&, i&
                
    Application.ScreenUpdating = False
    Set wsData = Sheets("DATA")
    If wsData.FilterMode Then wsData.ShowAllData
    lastrow = wsData.Cells(Rows.Count, "C").End(xlUp).Row
    Set dicSection = CreateObject("Scripting.Dictionary")
    dicSection.CompareMode = 1 'vbTextCompare
    vSection = wsData.Range("C7:C" & lastrow)
        
    For i = 1 To UBound(vSection)
        dicSection(vSection(i, 1)) = ""
    Next i

    For Each vItem In dicSection.keys()
        With wsData.Range("C6:N" & lastrow)
            .AutoFilter field:=1, Criteria1:=vItem
                    For i = 1 To 11
                        Set rScore = .Offset(1, i).Resize(.Rows.Count, 1).SpecialCells(xlCellTypeVisible)
                        For Each rCell In rScore
                            Score = rCell.Value
                            If Application.IsNumber(Score) Then
                                Rnk = WorksheetFunction.Rank(CDbl(Score), rScore)
                                rCell.Offset(, 14).Value = Rnk & DefaultGetSuffix(Rnk)
                            End If
                        Next rCell
            .AutoFilter
        End With
    Next vItem
  Application.ScreenUpdating = True
End Sub


Function DefaultGetSuffix(Rnk#) As String
    Dim sSuffix$
    If Rnk Mod 100 >= 11 And Rnk Mod 100 <= 20 Then
        sSuffix = " th"
    Else
        Select Case (Rnk Mod 10)
            Case 1: sSuffix = " st"
            Case 2: sSuffix = " nd"
            Case 3: sSuffix = " rd"
            Case Else: sSuffix = " th"
        End Select
    End If
    DefaultGetSuffix = sSuffix
End Function

Script #2
Code:
Sub MySwitch()
    For Each eItem In Range("C7:C" & lr).Cells
        Select Case eItem.Text
            Case 3: eItem = "Y 1"
            Case 4: eItem = "Y 2"
            Case 5: eItem = "X 1"
            Case 6: eItem = "X 2"
            Case 7: eItem = "X 3"
            Case 8: eItem = "X 4"
            Case 9: eItem = "X 5"
            Case 10: eItem = "X 6"
            Case 11: eItem = "Z 1"
            Case 12: eItem = "Z 2"
            Case 13: eItem = "Z 3"
        End Select
    Next eItem
End Sub

Script #3
Code:
Sub NumberEachCat()
    Dim r As Range, counter&, currentS$
    
    With Sheets("DATA")
        lr = .Range("C" & Rows.Count).End(xlUp).Row
        If lr < 7 Then lr = 7
        currentS = .[A7].Value: counter = 1
        For Each r In .Range("C7:C" & lr)
           If currentS = r.Value Then
                r.Offset(, -2) = counter
                counter = counter + 1
            Else
                counter = 1
                r.Offset(, -2) = counter
                counter = counter + 1
                currentS = r.Value
            End If
        Next r
    End With
End Sub
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

dataluver

Board Regular
Joined
Jan 17, 2020
Messages
193
Office Version
365
Platform
Windows
Just a couple of suggestions. Using early binding may provide a negligible increase in speed.
dicSection As Object would become
dicSection As Scripting.Dictionary
You will need to set a reference to Microsoft Scripting Runtime

You may see a significant improvement if you have more than a handful of elements by assigning dicSection.keys() to a variant and then working with the variant.
So
For Each vItem In dicSection.keys()
would change into something along these lines.
Dim keys As Variant
keys = dicSection.keys()
For Each vItem In keys

I don't have time to really look at all of your code right now, but those two things popped. Try it.
 

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,728
Office Version
2016
Platform
Windows
Just a couple of suggestions. Using early binding may provide a negligible increase in speed.
dicSection As Object would become
dicSection As Scripting.Dictionary
You will need to set a reference to Microsoft Scripting Runtime

You may see a significant improvement if you have more than a handful of elements by assigning dicSection.keys() to a variant and then working with the variant.
So
For Each vItem In dicSection.keys()
would change into something along these lines.
Dim keys As Variant
keys = dicSection.keys()
For Each vItem In keys

I don't have time to really look at all of your code right now, but those two things popped. Try it.
Okay thanks for the tips. I wish I fully understand what you meant by those elements.
That code was by one MVP here then later revised by @DanteAmor

I am sure they will pass by and have a look.

Regards
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,482
Script #1 [untested] try:
VBA Code:
Sub RI2()

    Dim x   As Long
    
    With Sheets("DATA")
        If .FilterMode Then .ShowAllData
        x = .Cells(.Rows.Count, 3).End(xlUp).Row
        .Cells(7, 17).Resize(UBound(o, 1), UBound(o, 2)).Value = Gen_Output(Fill_Dic(.Cells(7, 3).Resize(x - 6).Value), .Cells(6, 3).Resize(x - 5, 12).Value)
    End With

End Sub

Private Function Fill_Dic(ByRef arr As Variant) As Variant

    Dim d   As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim x   As Long

    For x = LBound(arr, 1) To UBound(arr, 1)
        d(a, x1) = ""
    Next x

    Set Fill_Dic = d: Set d = Nothing

End Function

Private Function Suffix(ByRef Rnk As Double) As String

    Dim b As Double: b = Rnk Mod 100

    Suffix = Rnk & " th"

    If b < 11 Or b > 20 Then Suffix = Rnk & " th"
    b = Rnk Mod 10
    If b < 4 Then Suffix = Rnk & " " & Mid("stndrd", (b * 2) - 1, 2)

End Function

Private Function Gen_Output(ByRef d As Object, ByRef a As Variant) As Variant

    Dim x   As Long
    Dim o   As Variant: ReDim o(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)

    For x = LBound(a, 1) To UBound(a, 1)
        If d.exists(a(x, 1)) Then
            For y = LBound(a, 2) + 1 To UBound(a, 2)
                If a(x, y) <> "" And IsNumeric(a(x, y)) Then o(x, y - 1) = Suffix(Application.Rank(CDbl(a(x, y)), Application.Index(a, x, 0)))
            Next y
        End If
    Next x

    Gen_Output = o: Erase o

End Function
Script #2 [untested], try:
VBA Code:
Sub MySwitch()

    Dim x   As Long
    Dim a   As Variant
    Dim d   As Object: Set d = CreateObject("Scripting.Dictionary")
   
    a = Array("Y 1", "Y 2", "X 1", "X 2", "X 3", "X 4", "X 5", "X 6", "Z 1", "Z 2", "Z 3")
       
    For x = LBound(a) To UBound(a)
        d(x + 3) = a(x)
    Next x
   
    x = Application.Max(7, Cells(Rows.Count, 3).End(xlUp).Row)
    a = Cells(7, 3).Resize(x - 6).Value
   
    For x = LBound(a, 1) To UBound(a, 1)
        If a(x, 1) > 2 And a(x, 1) < 14 Then a(x, 1) = d(x)
    Next x
   
    Cells(7, 3).Resize(UBound(a, 1), UBound(a, 2)).Value = a
   
    Erase a: Set d = Nothing

End Sub
Script #3 [untested]. try:
VBA Code:
Sub NumberEachCat()
        
    Dim x   As Long
    Dim i   As Long: i = 1

    Dim a   As Variant
    Dim s   As String

    With Sheets("DATA")
        x = Application.Max(7, .Cells(.Rows.Count, 3).End(xlUp).Row)
        If .AutoFilterMode Then .AutoFilterMode = False
        a = .Cells(7, 1).Resize(x - 6, 3).Value: s = a(1,1)
        For x = LBound(a, 1) To UBound(a, 1)
            If CStr(a(x, 3)) <> s Then
                i = 1
                s = a(x, 3)
            End If
            a(x, 1) = i
            i = i + 1
        Next x
        .Cells(7, 1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
    End With

    Erase a
End Sub
 
Last edited:

dataluver

Board Regular
Joined
Jan 17, 2020
Messages
193
Office Version
365
Platform
Windows
Disregard my earlier post. Out of curiosity, I just tested it on 1 million elements and saw no noticeable difference. I do remember, some time ago, that I gained a huge performance jump, but I don't remember the context. Frankly, with as fast as computers are nowadays, I'm not sure that there is a perceptible difference between early and late binding either.

When I spoke of elements, I was referring to one value pair in the dictionary. Not sure if that is the absolute proper terminology, but I see a dictionary as a close relative to an array.
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,482
but I see a dictionary as a close relative to an array.
Hey dataluver, think of it as a 2 column array with unique (sorted or unsorted) values (keys) in first column and related item in 2nd column - like a 1:1 map or 2 column VLOOKUP table
 

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,728
Office Version
2016
Platform
Windows
Hi @JackDanIce ,

I got an error here :

Code:
Sub RI2()

    Dim x   As Long
    
    With Sheets("DATA")
        If .FilterMode Then .ShowAllData
        x = .Cells(.Rows.Count, 3).End(xlUp).Row
        .Cells(7, 17).Resize(UBound(o, 1), UBound(o, 2)).Value = Gen_Output(Fill_Dic(.Cells(7, 3).Resize(x - 6).Value), .Cells(6, 3).Resize(x - 5, 12).Value)
    End With

End Sub
Error line:

Code:
Cells(7, 17).Resize(UBound(o, 1), UBound(o, 2)).Value = Gen_Output(Fill_Dic(.Cells(7, 3).Resize(x - 6).Value), .Cells(6, 3).Resize(x - 5, 12).Value)
Variable not defined "o"
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,482
Apologies, editting as typing and deleted by mistake, try:
VBA Code:
Sub RI2()

    Dim x   As Long
    Dim o   As Variant
  
    With Sheets("DATA")
        If .FilterMode Then .ShowAllData
        x = Application.Max(.Cells(.Rows.Count, 3).End(xlUp).row, 7) - 6
       o = .Cells(3, 7).Resize(x, 12).Value
        .Cells(7, 17).Resize(UBound(o, 1), UBound(o, 2)).Value = Gen_Output(Fill_Dic(.Cells(7, 3).Resize(x - 6).Value), .Cells(6, 3).Resize(x - 5, 12).Value)
    End With

    Erase o

End Sub
 

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
1,728
Office Version
2016
Platform
Windows
Apologies, editting as typing and deleted by mistake, try:
VBA Code:
Sub RI2()

    Dim x   As Long
    Dim o   As Variant
  
    With Sheets("DATA")
        If .FilterMode Then .ShowAllData
        x = Application.Max(.Cells(.Rows.Count, 3).End(xlUp).row, 7) - 6
       o = .Cells(3, 7).Resize(x, 12).Value
        .Cells(7, 17).Resize(UBound(o, 1), UBound(o, 2)).Value = Gen_Output(Fill_Dic(.Cells(7, 3).Resize(x - 6).Value), .Cells(6, 3).Resize(x - 5, 12).Value)
    End With

    Erase o

End Sub
Please look at this function, some variables are not defined.

The a and x1 - errors show up.

When I did arr for a and x for x1

I can't tell for the other functions since I have not reached them yet.
 

Forum statistics

Threads
1,089,518
Messages
5,408,755
Members
403,224
Latest member
rholmesa

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top