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

[kelly mort]

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:

Load part of data to memory, perform some calculations and rank then show alert with message box -vba

This is the formula I am using to get data to second sheet. Sheet2.Range("D7:M" & lr) = "=Sheet1!I7+Sheet1!S7*0.2" Sheet1 Sheet2 Now what I want to do is to be able to load the portion of data from sheet2 for say category "X" into memory. Now I don't want to interact with the worksheet...

www.mrexcel.com

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

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

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

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

 

[DanteAmor]

When I switched to your version, all went well

Your code is very cute.

I'm glad to help you. Thanks for the feedback.

 

[kelly mort]

Hi @DanteAmor,

When I said blank cells, I never meant there will be no records at all.

There will be data yet some cells will be blank. In that case I run into type mismatch error.

That's what I want to skip

 

[DanteAmor]

some cells will be blank

Try this

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 Variant, nums2 As Variant
  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 = Val(Split(sRow(i), "#")(j))
        For k = 1 To UBound(sRow)
          nums2 = Val(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

 

[DanteAmor]

This part of one of my codes too need optimization. I will be glad if you look at it too for me.

This is another topic, please create a new thread.

 

[kelly mort]

This worked great:

Two last request then I will be cool to go
1. Assuming I want to rank for only column N and place the output in column AB, which part of the code should be modified?

The reason is that at one point in time, I will need a case switch to rank only column N into AB whereas at some point too I will rank from D to N as the code has been doing so far.

2. Will it be possible to remove the rank for the blank cells before placing the data on the sheet?
Currently, it is ranking the blanks. Which I want to get blank spaces ahown.

Very grateful for your help

 

[DanteAmor]

1. Assuming I want to rank for only column N and place the output in column AB, which part of the code should be modified?

Change this:
For j = 1 To 11

For this:
For j = 11 To 11
_______________________________________________________________________________________________________

 

[DanteAmor]

2. Will it be possible to remove the rank for the blank cells before placing the data on the sheet?

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 Variant, nums2 As Variant
  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)
        If nums <> "" Then
          nums = Val(nums)
          For k = 1 To UBound(sRow)
            nums2 = Val(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)
        Else
          c(ii, j) = ""
        End If
      Next i
    Next ky
  Next j
 
  sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c
End Sub

 

[kelly mort]

Change this:
For j = 1 To 11

For this:
For j = 11 To 11
_______________________________________________________________________________________________________

In that case how do I make sure this line places for just AB?

I will be having some data in R:AA by then but this line overrides them.

  sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c

Post #27 has resolved their two requests.

You are very intelligent

 

[DanteAmor]

I will be having some data in R:AA by then but this line overrides them.

Change this lines:
For j = 1 To 11

sh.Range("R7").Resize(UBound(c, 1), UBound(c, 2)).Value = c

For this lines:
For j = 11 To 11

sh.Range("AB7").Resize(UBound(c, 1)).Value = c

 

[kelly mort]

sh.Range("AB7").Resize(UBound(c, 1)).Value = c

This line is just placing blanks to column AB.