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

[Woodpusher147]

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

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

 

[RoryA]

What's the value of cf_formula when the error occurs?

 

[Woodpusher147]

What's the value of cf_formula when the error occurs?

Thank you for the quick reply.
Im afraid I'm not sure how to get that.
Sorry but this is not my skill at all which is why I came here in the first place :/

How can I find that value?


THanks

 

[RoryA]

When the code breaks and you press Debug, in the immediate window (Ctrl+G if it's not already visible) type:

?cf_formula

and press enter.

 

[Woodpusher147]

?cf_formula
=OR)

Thanks again

 

[RoryA]

There's the problem then. That is not a valid formula.

 

[Woodpusher147]

OK but what can I do?

ITs part of this

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

I really have no idea what I can do but really need to sort :/


THanks again

 

[RoryA]

It would appear that the descendingListWithoutDuplicates array is empty. There's too much code there (and no data) for me to tell you why.

 

[Woodpusher147]

Is there any way you can help.

Pretty desperate here

 

[RoryA]

I'd need the workbook. The most likely issue I can suggest from a quick skim is that the code doesn't specify which sheet to get the list from, so it will be working off whatever sheet is active.