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

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. 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
 
Code:
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

This function
 
Upvote 0

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Top line, change to:

(ByRef arr As Variant) As Object

If doesn't work, will try to mock up something tomorrow and test first!
 
Upvote 0
Top line, change to:

(ByRef arr As Variant) As Object

If doesn't work, will try to mock up something tomorrow and test first!
It did not work.

What about the change in made to the variables; a to arr and x1 to x?

Right or wrong?
 
Upvote 0
Hi kelly mort, here the script 2 and 3 for you to consider.
Working in script 1...

VBA Code:
Sub MySwitch()
'Script #2
  Dim a As Variant, b As Variant, i As Long
  
  a = Range("C7", Range("C" & Rows.Count).End(3)).Value2
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    Select Case a(i, 1)
        Case 3:  b(i, 1) = "Y 1"
        Case 4:  b(i, 1) = "Y 2"
        Case 5:  b(i, 1) = "X 1"
        Case 6:  b(i, 1) = "X 2"
        Case 7:  b(i, 1) = "X 3"
        Case 8:  b(i, 1) = "X 4"
        Case 9:  b(i, 1) = "X 5"
        Case 10: b(i, 1) = "X 6"
        Case 11: b(i, 1) = "Z 1"
        Case 12: b(i, 1) = "Z 2"
        Case 13: b(i, 1) = "Z 3"
    End Select
  Next
  Range("C7").Resize(UBound(b)).Value = b
End Sub

VBA Code:
Sub NumberEachCat()
'Script #3
  Dim sh As Worksheet, a As Variant, b As Variant
  Dim i As Long, dic As Object
  
  Set sh = Sheets("DATA")
  a = sh.Range("C7", sh.Range("C" & Rows.Count).End(3)).Value2
  ReDim b(1 To UBound(a), 1 To 1)
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    dic(a(i, 1)) = dic(a(i, 1)) + 1
    b(i, 1) = dic(a(i, 1))
  Next
  
  sh.Range("A7").Resize(UBound(b)).Value = b
End Sub
 
Upvote 0
Hi kelly mort, here the script 1 for you to consider.

VBA Code:
Sub RankIt()
'Script #1
  Dim sh As Worksheet, dic As Object, ky As Variant, cad As String
  Dim a As Variant, c As Variant, sRow As Variant, nums As Double, nums2 As Double
  Dim i As Long, j As Long, ii As Long, k As Long, Rnk As Long
  
  Application.ScreenUpdating = False
  Set sh = Sheets("DATA")
  If sh.FilterMode Then sh.ShowAllData
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = 1
  a = sh.Range("C7:N" & sh.Range("C" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
  
  For i = 1 To UBound(a, 1)
    cad = i & "#"
    For j = 2 To UBound(a, 2)
      cad = cad & a(i, j) & "#"
    Next
    dic(a(i, 1)) = dic(a(i, 1)) & "|" & cad
  Next
  
  For j = 1 To 11
    For Each ky In dic.keys
      sRow = Split(dic(ky), "|")
      For i = 1 To UBound(sRow)
        Rnk = 1
        ii = Split(sRow(i), "#")(0)
        nums = Split(sRow(i), "#")(j)
        For k = 1 To UBound(sRow)
          nums2 = Split(sRow(k), "#")(j)
          If nums2 > nums Then Rnk = Rnk + 1
        Next k
        c(ii, j) = Rnk & " " & Mid("thstndrdthththththth", 1 - 2 * (Rnk Mod 10) * (Abs(Rnk Mod 100 - 12) > 1), 2)
      Next i
    Next ky
  Next j
  
  sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub
 
Upvote 0
Hi kelly mort, here the script 1 for you to consider.

VBA Code:
Sub RankIt()
'Script #1
  Dim sh As Worksheet, dic As Object, ky As Variant, cad As String
  Dim a As Variant, c As Variant, sRow As Variant, nums As Double, nums2 As Double
  Dim i As Long, j As Long, ii As Long, k As Long, Rnk As Long
  
  Application.ScreenUpdating = False
  Set sh = Sheets("DATA")
  If sh.FilterMode Then sh.ShowAllData
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = 1
  a = sh.Range("C7:N" & sh.Range("C" & Rows.Count).End(3).Row).Value2
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
  
  For i = 1 To UBound(a, 1)
    cad = i & "#"
    For j = 2 To UBound(a, 2)
      cad = cad & a(i, j) & "#"
    Next
    dic(a(i, 1)) = dic(a(i, 1)) & "|" & cad
  Next
  
  For j = 1 To 11
    For Each ky In dic.keys
      sRow = Split(dic(ky), "|")
      For i = 1 To UBound(sRow)
        Rnk = 1
        ii = Split(sRow(i), "#")(0)
        nums = Split(sRow(i), "#")(j)
        For k = 1 To UBound(sRow)
          nums2 = Split(sRow(k), "#")(j)
          If nums2 > nums Then Rnk = Rnk + 1
        Next k
        c(ii, j) = Rnk & " " & Mid("thstndrdthththththth", 1 - 2 * (Rnk Mod 10) * (Abs(Rnk Mod 100 - 12) > 1), 2)
      Next i
    Next ky
  Next j
  
  sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

Great!!!

The only issue is that I run into errors at blank cells.

How do I accommodate blank cells?
 
Upvote 0
Also, it is not ranking uniquely based on categories in column C As in the original post
Please discard this post. It was an error from the version of script #2 from @JackDanIce . When I switched to your version, all went well

Your code is very cute.

Only the blank issue is what I want you address for me thanks
 
Upvote 0
This part of one of my codes too need optimization. I will be glad if you look at it too for me.
Code:
                    For i = 1 To 10
                        For Each cel In .Range("R7:R" & lr).Offset(, i - 1)
                            Select Case .Cells(cel.Row, "C")
                                Case "Z " & 1 To "Z " & 3
                                    Select Case cel.Value
                                        Case Is >= 83: cel = 1
                                        Case Is >= 76: cel = 2
                                        Case Is >= 69: cel = 3
                                        Case Is >= 60: cel = 4
                                        Case Is >= 50: cel = 5
                                        Case Is >= 40: cel = 6
                                        Case Is >= 30: cel = 7
                                        Case Is >= 20: cel = 8
                                        Case Is >= 1:  cel = 9
                                    End Select
                                Case Else
                                   Select Case cel.Value
                                        Case Is >= 80: cel = 1
                                        Case Is >= 75: cel = 2
                                        Case Is >= 70: cel = 3
                                        Case Is >= 65: cel = 4
                                        Case Is >= 1:  cel = 5
                                    End Select
                            End Select
                        Next cel
                    Next i
 
Upvote 0
The only issue is that I run into errors at blank cells.

Code set for when there are no records.

VBA Code:
Sub RankIt()
'Script #1
  Dim sh As Worksheet, dic As Object, ky As Variant, cad As String
  Dim a As Variant, c As Variant, sRow As Variant, nums As Double, nums2 As Double
  Dim i As Long, j As Long, ii As Long, k As Long, Rnk As Long, lr As Long
  
  Application.ScreenUpdating = False
  Set sh = Sheets("DATA")
  If sh.FilterMode Then sh.ShowAllData
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = 1
  lr = sh.Range("C" & Rows.Count).End(3).Row
  If lr < 7 Then Exit Sub
  a = sh.Range("C7:N" & lr).Value2
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
  
  For i = 1 To UBound(a, 1)
    cad = i & "#"
    For j = 2 To UBound(a, 2)
      cad = cad & a(i, j) & "#"
    Next
    dic(a(i, 1)) = dic(a(i, 1)) & "|" & cad
  Next
  
  For j = 1 To 11
    For Each ky In dic.keys
      sRow = Split(dic(ky), "|")
      For i = 1 To UBound(sRow)
        Rnk = 1
        ii = Split(sRow(i), "#")(0)
        nums = Split(sRow(i), "#")(j)
        For k = 1 To UBound(sRow)
          nums2 = Split(sRow(k), "#")(j)
          If nums2 > nums Then Rnk = Rnk + 1
        Next k
        c(ii, j) = Rnk & " " & Mid("thstndrdthththththth", 1 - 2 * (Rnk Mod 10) * (Abs(Rnk Mod 100 - 12) > 1), 2)
      Next i
    Next ky
  Next j
  
  sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,912
Members
452,366
Latest member
TePunaBloke

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
Back
Top