Runtime Error 5 on very complicated sheet (to me anyway :) )

Woodpusher147

Board Regular
Joined
Oct 6, 2021
Messages
69
Office Version
  1. 365
Platform
  1. Windows
Hello
Really hope someone can help with a runtime error I am receiving on pretty complicated workbook.
Someone on here helped me create this but now I cant contact him so I am pretty stuck.

Debug shows the error on this section of the below code
1638530243602.png


VBA Code:
Option Explicit

Sub Set_Conditional_Formatting()
Dim firstRow&, lastRow&, columnLetter$, red, amber, green, gold, fontColorForRedCells, settingsSheetName$
ReDim descendingListWithoutDuplicates(0 To 0) As String

'**********************************************************
'Inputs
settingsSheetName = "Settings"

red = RGB(255, 0, 0)  'Red
amber = RGB(255, 230, 153) 'Amber
green = RGB(0, 176, 80) 'Green
gold = RGB(255, 255, 0) 'Gold
fontColorForRedCells = RGB(255, 255, 255) 'White
'**********************************************************

ActiveSheet.Cells.FormatConditions.Delete
firstRow = FirstDataRow_In_Current_Sheet(ActiveSheet.Name, settingsSheetName)
lastRow = LastActualDataRow_In_This_Sheet(ActiveSheet.Name, settingsSheetName)

columnLetter = "F"
Call LessThan(85, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(85, 99, columnLetter, firstRow, lastRow, amber)
Call Between(100, 105, columnLetter, firstRow, lastRow, green)
Call GreaterThan(105, columnLetter, firstRow, lastRow, gold)

    columnLetter = "G"
    descendingListWithoutDuplicates = List_Of_Scores_In_Descending_Order_Without_Duplicates(firstRow, lastRow, columnLetter)
    Call Between_Ranks(">9", descendingListWithoutDuplicates, columnLetter, firstRow, lastRow, red, fontColorForRedCells) 'BElow 9th
    Call Between_Ranks("8-9", descendingListWithoutDuplicates, columnLetter, firstRow, lastRow, amber) 'NEXT 2 so 8th and 9th
    Call Between_Ranks("5-7", descendingListWithoutDuplicates, columnLetter, firstRow, lastRow, green) 'NEXT 3 so 5th to 7th
    Call Between_Ranks("1-4", descendingListWithoutDuplicates, columnLetter, firstRow, lastRow, gold) 'TOP 4 SCORES

'    Call LessThan(70, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
'    Call Between(70, 74, columnLetter, firstRow, lastRow, amber)
'    Call Between(75, 79, columnLetter, firstRow, lastRow, green)
'    Call GreaterThan(79, columnLetter, firstRow, lastRow, gold)

columnLetter = "H"
Call LessThan(5, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(5, 9, columnLetter, firstRow, lastRow, amber)
Call Between(10, 14, columnLetter, firstRow, lastRow, green)
Call GreaterThan(14, columnLetter, firstRow, lastRow, gold)

columnLetter = "I"
Call LessThan(65, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(65, 69, columnLetter, firstRow, lastRow, amber)
Call Between(70, 74, columnLetter, firstRow, lastRow, green)
Call GreaterThan(74, columnLetter, firstRow, lastRow, gold)

columnLetter = "J"
Call LessThan(20, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(20, 23, columnLetter, firstRow, lastRow, amber)
Call Between(24, 29, columnLetter, firstRow, lastRow, green)
Call GreaterThan(29, columnLetter, firstRow, lastRow, gold)

columnLetter = "K"
Call LessThan(75, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(75, 79, columnLetter, firstRow, lastRow, amber)
Call Between(80, 84, columnLetter, firstRow, lastRow, green)
Call GreaterThan(84, columnLetter, firstRow, lastRow, gold)

columnLetter = "L"
Call LessThan(20, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(20, 25, columnLetter, firstRow, lastRow, amber)
Call Between(26, 33, columnLetter, firstRow, lastRow, green)
Call GreaterThan(33, columnLetter, firstRow, lastRow, gold)

columnLetter = "M"
Call LessThan(20, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(20, 25, columnLetter, firstRow, lastRow, amber)
Call Between(26, 33, columnLetter, firstRow, lastRow, green)
Call GreaterThan(33, columnLetter, firstRow, lastRow, gold)

columnLetter = "N"
Call LessThan(35, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(35, 39, columnLetter, firstRow, lastRow, amber)
Call Between(40, 59, columnLetter, firstRow, lastRow, green)
Call GreaterThan(59, columnLetter, firstRow, lastRow, gold)

columnLetter = "O"
Call LessThan(50, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(50, 64, columnLetter, firstRow, lastRow, amber)
Call Between(65, 74, columnLetter, firstRow, lastRow, green)
Call GreaterThan(74, columnLetter, firstRow, lastRow, gold)

columnLetter = "P"
Call LessThan(80, columnLetter, firstRow, lastRow, red, fontColorForRedCells)
Call Between(80, 84, columnLetter, firstRow, lastRow, amber)
Call Between(85, 89, columnLetter, firstRow, lastRow, green)
Call GreaterThan(89, columnLetter, firstRow, lastRow, gold)

End Sub

Sub DeleteFormatConditions(columnLetter1 As String, columnLetter2 As String, firstRow As Long, lastRow As Long)
Range(columnLetter1 & firstRow & ":" & columnLetter2 & lastRow).FormatConditions.Delete
End Sub

Sub LessThan(num As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)
With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlCellValue, Operator:=xlBetween, Formula1:=1, Formula2:=num - 1)
    .Interior.Color = colorr
    .Font.Color = fontColor
    .StopIfTrue = False
End With
End Sub

Sub GreaterThan(num As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)
With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=num)
    .Interior.Color = colorr
    .Font.Color = fontColor
    .StopIfTrue = False
End With
End Sub

Sub Between(num1 As Variant, num2 As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)
With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlCellValue, Operator:=xlBetween, Formula1:=num1, Formula2:=num2)
    .Interior.Color = colorr
    .Font.Color = fontColor
    .StopIfTrue = False
End With
End Sub
Sub Test__Between_Ranks()

Dim firstRow&, lastRow&, columnLetter$, red, amber, green, gold, fontColorForRedCells, settingsSheetName$, columnLetterOfPoints$
ReDim descendingListWithoutDuplicates(0 To 0) As String

red = RGB(255, 0, 0)  'Red
amber = RGB(255, 230, 153) 'Amber
green = RGB(0, 176, 80) 'Green
gold = RGB(255, 255, 0) 'Gold
fontColorForRedCells = RGB(255, 255, 255) 'White

settingsSheetName = "Settings"
columnLetter = "G"
firstRow = 7
lastRow = LastActualDataRow_In_This_Sheet(ActiveSheet.Name, settingsSheetName)

descendingListWithoutDuplicates = List_Of_Scores_In_Descending_Order_Without_Duplicates(firstRow, lastRow, columnLetter)
Call Between_Ranks(">7", descendingListWithoutDuplicates, columnLetter, firstRow, lastRow, red, fontColorForRedCells)

End Sub
Sub Between_Ranks(expr As String, descendingListWithoutDuplicates As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)

Dim num1 As Variant
Dim num2 As Variant
ReDim twoNumbers(0 To 1) As String

If InStr(expr, ">") > 0 Then
    num1 = Trim(SubString(expr, InStr(expr, ">") + 1, Len(expr)))
    num2 = num1
Else
    twoNumbers = Split(expr, "-")
    num1 = twoNumbers(0)
    num2 = twoNumbers(1)
End If

Dim i As Integer

'OR(G7=32,G7=111)

Dim cf_Formula As String
cf_Formula = "=OR("

'Debug.Print expr

If num1 = num2 Then
    i = num1
    Do While i <= UBound(descendingListWithoutDuplicates)
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
Else
    'Debug.Print "[" & num1 & "," & num2 & "]"
    i = num1 - 1
    Do While i <= num2 - 1
        'Debug.Print descendingListWithoutDuplicates(i), i
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
End If
cf_Formula = SubString(cf_Formula, 1, Len(cf_Formula) - 1)
cf_Formula = cf_Formula & ")"

'Debug.Print cf_Formula

With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlExpression, Formula1:=cf_Formula)
    .Interior.Color = colorr
    .Font.Color = fontColor
    .StopIfTrue = False
End With

End Sub






Sub Test__List_Of_Scores_In_Descending_Order_Without_Duplicates()

Dim settingsSheetName As String
settingsSheetName = "Settings"

Dim columnLetter As String
columnLetter = "G"

Dim firstRow As Long
firstRow = FirstDataRow_In_Current_Sheet(ActiveSheet.Name, settingsSheetName)

Dim lastRow As Long
lastRow = LastActualDataRow_In_This_Sheet(ActiveSheet.Name, settingsSheetName)

ReDim descendingListWithoutDuplicates(0 To 0) As String
descendingListWithoutDuplicates = List_Of_Scores_In_Descending_Order_Without_Duplicates(firstRow, lastRow, columnLetter)

Debug.Print "------------------"

Dim i As Integer
i = 0
Do While i <= UBound(descendingListWithoutDuplicates)
    Debug.Print descendingListWithoutDuplicates(i), i + 1
    i = i + 1
Loop

Debug.Print "------------------"

End Sub
Function List_Of_Scores_In_Descending_Order_Without_Duplicates(firstRow As Long, lastRow As Long, columnLetter As String)

Dim i As Integer
Dim stringListOfScores As String

Dim arr() As Variant
arr = Range(columnLetter & firstRow & ":" & columnLetter & lastRow)
arr = Quicksort(arr, 1, UBound(arr))

'DeleteDuplicates
stringListOfScores = ""
i = UBound(arr)
Do While i >= 1
    If Trim(arr(i, 1)) = "" Then arr(i, 1) = 0
    stringListOfScores = stringListOfScores & arr(i, 1) & ","
    'Debug.Print arr(i, 1)
    i = i - 1
Loop
stringListOfScores = SubString(stringListOfScores, 1, Len(stringListOfScores) - 1)
'Debug.Print stringListOfScores

stringListOfScores = NoDupWords(stringListOfScores, ",")
'Debug.Print stringListOfScores

ReDim descendingListWithoutDuplicates(0 To 0) As String
descendingListWithoutDuplicates = Split(stringListOfScores, ",")

List_Of_Scores_In_Descending_Order_Without_Duplicates = descendingListWithoutDuplicates

End Function




Sub Test__LastActualDataRow_In_This_Sheet()
MsgBox LastActualDataRow_In_This_Sheet(ActiveSheet.Name, "Settings")
End Sub
Function LastActualDataRow_In_This_Sheet(sheetName As String, settingsSheetName As String)

Dim departmentColumnLetterInCurrentStoreSheet As String
Dim currentSheetRowInSettingsSheet As Long
currentSheetRowInSettingsSheet = First_Row_With_This_Text_In_This_Column(settingsSheetName, "A", sheetName)

Dim i As Integer
i = 1
Do While i <= Last_Non_Blank_Column_In_This_Row(settingsSheetName, 4)
    If InStr(Sheets(settingsSheetName).Cells(4, i), "*") > 0 Then
        departmentColumnLetterInCurrentStoreSheet = Split(Sheets(settingsSheetName).Range(Sheets(settingsSheetName).Cells(currentSheetRowInSettingsSheet, i).Value).Address, "$")(1)
        GoTo Next_Step
    End If
    i = i + 1
Loop
Next_Step:
LastActualDataRow_In_This_Sheet = Last_Non_Blank_Row_In_This_Column(sheetName, departmentColumnLetterInCurrentStoreSheet)

End Function


Sub Test__Quicksort()

Dim arr() As Variant
arr = Range("Q6:Q18")
arr = Quicksort(arr, 1, UBound(arr))
Dim i As Integer
i = 1
Do While i <= UBound(arr)
    Debug.Print arr(i, 1)
    i = i + 1
Loop

End Sub
Function Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
'Sorts a one-dimensional VBA array from smallest to largest
'using a very fast quicksort algorithm variant.
Dim pivotVal As Variant
Dim vSwap    As Variant
Dim tmpLow   As Long
Dim tmpHi    As Long
 
tmpLow = arrLbound
tmpHi = arrUbound
pivotVal = vArray((arrLbound + arrUbound) \ 2, 1)
 
While (tmpLow <= tmpHi) 'divide
   While (vArray(tmpLow, 1) < pivotVal And tmpLow < arrUbound)
      tmpLow = tmpLow + 1
   Wend
  
   While (pivotVal < vArray(tmpHi, 1) And tmpHi > arrLbound)
      tmpHi = tmpHi - 1
   Wend
 
   If (tmpLow <= tmpHi) Then
      vSwap = vArray(tmpLow, 1)
      vArray(tmpLow, 1) = vArray(tmpHi, 1)
      vArray(tmpHi, 1) = vSwap
      tmpLow = tmpLow + 1
      tmpHi = tmpHi - 1
   End If
Wend
 
  If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
  If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer

Quicksort = vArray

End Function



Sub Test__FirstDataRow_In_Current_Sheet()
MsgBox FirstDataRow_In_Current_Sheet(ActiveSheet.Name, "Settings")
End Sub
Function FirstDataRow_In_Current_Sheet(sheetName As String, settingsSheetName As String)

Dim currentSheetRowInSettingsSheet As Long
Dim cellAddress As String
currentSheetRowInSettingsSheet = First_Row_With_This_Text_In_This_Column(settingsSheetName, "A", sheetName)
If currentSheetRowInSettingsSheet = 0 Then
    MsgBox "This store sheet name is not listed (verbatim) in the settings sheet!", vbCritical, "Conditional Formatting Not Set"
    End
End If

Dim i As Integer
i = 1
Do While i <= Last_Non_Blank_Column_In_This_Row(settingsSheetName, 4)
    If InStr(Sheets(settingsSheetName).Cells(4, i), "&") > 0 Then
        cellAddress = Sheets(settingsSheetName).Cells(currentSheetRowInSettingsSheet, i).Value
        FirstDataRow_In_Current_Sheet = Range(cellAddress).Row
        Exit Function
    End If
    i = i + 1
Loop

End Function


'==========================================
'Not used, but may be needed in the future!
'==========================================
Sub Test__ColumnLetter_WithPoints_In_Current_Sheet()
MsgBox ColumnLetter_WithPoints_In_Current_Sheet(ActiveSheet.Name, "Settings")(1)
MsgBox ColumnLetter_WithPoints_In_Current_Sheet(ActiveSheet.Name, "Settings")(2)
End Sub
Function ColumnLetter_WithPoints_In_Current_Sheet(sheetName As String, settingsSheetName As String)

Dim currentSheetRowInSettingsSheet As Long
Dim cellAddress As String
currentSheetRowInSettingsSheet = First_Row_With_This_Text_In_This_Column(settingsSheetName, "A", sheetName)
If currentSheetRowInSettingsSheet = 0 Then
    MsgBox "This store sheet name is not listed (verbatim) in the settings sheet!", vbCritical, "Conditional Formatting Not Set"
    End
End If

ReDim output(1 To 2) As String

Dim i As Integer
i = 1
Do While i <= Last_Non_Blank_Column_In_This_Row(settingsSheetName, 4)
    If InStr(Sheets(settingsSheetName).Cells(4, i), "&") > 0 Then
        cellAddress = Sheets(settingsSheetName).Cells(currentSheetRowInSettingsSheet, i).Value
        output(1) = Split(Sheets(settingsSheetName).Range(cellAddress).Address, "$")(1)
        output(2) = cellAddress
        ColumnLetter_WithPoints_In_Current_Sheet = output
        Exit Function
    End If
    i = i + 1
Loop

End Function


I can provide more details if there is anyone who thinks they could help

Many thanks for looking

Simon
 
Try changing the Between_Ranks routine to this:

VBA Code:
Sub Between_Ranks(expr As String, descendingListWithoutDuplicates As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)

Dim num1 As Variant
Dim num2 As Variant
ReDim twoNumbers(0 To 1) As String

If InStr(expr, ">") > 0 Then
    num1 = Trim(SubString(expr, InStr(expr, ">") + 1, Len(expr)))
    num2 = num1
Else
    twoNumbers = Split(expr, "-")
    num1 = twoNumbers(0)
    num2 = twoNumbers(1)
End If
' no need to process if rank band starts above number of entries
If num1 > UBound(descendingListWithoutDuplicates) + 1 Then Exit Sub
'if ranking band  ends above number of entries, cap it at that number
If num2 > UBound(descendingListWithoutDuplicates) + 1 Then num2 = UBound(descendingListWithoutDuplicates) + 1
Dim i As Integer

'OR(G7=32,G7=111)

Dim cf_Formula As String
cf_Formula = "=OR("

'Debug.Print expr

If num1 = num2 Then
    i = num1
    Do While i <= UBound(descendingListWithoutDuplicates)
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
Else
    'Debug.Print "[" & num1 & "," & num2 & "]"
    i = num1 - 1
    Do While i <= num2 - 1
        'Debug.Print descendingListWithoutDuplicates(i), i
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
End If

   cf_Formula = SubString(cf_Formula, 1, Len(cf_Formula) - 1)
   cf_Formula = cf_Formula & ")"
   
   'Debug.Print cf_Formula
   
   With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlExpression, Formula1:=cf_Formula)
       .Interior.Color = colorr
       .Font.Color = fontColor
       .StopIfTrue = False
   End With

End Sub
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
HI

THis looked like it worked but after a few alterations in the cells, the error returned
I changed sheet C column F to these figures and after changing the final 100 to 54 the error appeared again

:(
1638805318693.png
 
Upvote 0
HI

THis looked like it worked but after a few alterations in the cells, the error returned
I changed sheet C column F to these figures and after changing the final 100 to 54 the error appeared again

:(
View attachment 52775
Just try changing that highlited cell back to 100 and the update worked again, change it back to 54 and it fails , sorry, I'm confused :(
 
Upvote 0
It also works if I change the number to any other number that appears in the column
 
Upvote 0
Apologies - try this version:

Code:
Sub Between_Ranks(expr As String, descendingListWithoutDuplicates As Variant, columnLetter As String, firstRow As Long, lastRow As Long, colorr As Variant, Optional ByVal fontColor As Long = 0)

Dim num1 As Variant
Dim num2 As Variant
Dim UpperLimit As Long
ReDim twoNumbers(0 To 1) As String

If InStr(expr, ">") > 0 Then
    num1 = Trim(SubString(expr, InStr(expr, ">") + 1, Len(expr)))
    num2 = num1
    UpperLimit = UBound(descendingListWithoutDuplicates)
Else
    twoNumbers = Split(expr, "-")
    num1 = twoNumbers(0)
    num2 = twoNumbers(1)
    UpperLimit = UBound(descendingListWithoutDuplicates) + 1
End If
' no need to process if rank band starts above number of entries
If num1 > UpperLimit Then Exit Sub
'if ranking band  ends above number of entries, cap it at that number
If num2 > UpperLimit Then num2 = UpperLimit
Dim i As Integer

'OR(G7=32,G7=111)

Dim cf_Formula As String
cf_Formula = "=OR("

'Debug.Print expr

If num1 = num2 Then
    i = num1
    Do While i <= UBound(descendingListWithoutDuplicates)
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
Else
    'Debug.Print "[" & num1 & "," & num2 & "]"
    i = num1 - 1
    Do While i <= num2 - 1
        'Debug.Print descendingListWithoutDuplicates(i), i
        cf_Formula = cf_Formula & columnLetter & firstRow & "=" & descendingListWithoutDuplicates(i) & ","
        i = i + 1
    Loop
End If

   cf_Formula = SubString(cf_Formula, 1, Len(cf_Formula) - 1)
   cf_Formula = cf_Formula & ")"
   
   'Debug.Print cf_Formula
   
   With Range(columnLetter & firstRow & ":" & columnLetter & lastRow).FormatConditions.Add(Type:=xlExpression, Formula1:=cf_Formula)
       .Interior.Color = colorr
       .Font.Color = fontColor
       .StopIfTrue = False
   End With

End Sub
 
Upvote 0
Solution
NO need to apologise - your helping me out and I am very grateful

This looks great.
I will test further later on but I cant get it to error and the ranking looks perfect

Thank you very much.
 
Upvote 0

Forum statistics

Threads
1,223,883
Messages
6,175,168
Members
452,615
Latest member
bogeys2birdies

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