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

 

[Woodpusher147]

Strange thing is that it works at first.
I can add data then update but after about 3 times, that's when the error starts.
Is it possible for me to get the workbook to you to see?

 

[Woodpusher147]

Thank you for offering to help and to anyone else who takes their time to look and help

Here is the workbook

Dropbox

www.dropbox.com

The details of what the spec was and the help I received creating this are in the following thread.

Change cell value based on the color of another cell

Hello I hope someone can help with a (in my not super excel mind) very complicated issue. I have the above spreadsheet to track performance which has 11 columns and however many staff there are as rows. The sheet has conditional formating to shade each cell based on score, that's all done ok...

www.mrexcel.com

CMOWLA was a great help and created most of this but unfortunately, he is now uncontactable

Massive thanks to anyone who can help


Simon

 

[RoryA]

What are the steps to replicate the issue?

 

[Woodpusher147]

IT happened when I removed a row of data. the C column is still producing the error but I have just tried a few times in the DT tab and it doesn't seem to be creating the error



Apologies,, the pass is simply "aaa"

The password couldn't make any difference could it? Since I changed it from a m,moe secure one to aaa it seems I cant replicate the error on the other tabs
It was happening after about 3 clicks of the update button on all tabs

 

[RoryA]

OK, so the problem occurred on first run, because of the >9 range. There are only 7 unique records in the list, so although num1 (which is "9") = num2, there are fewer items in the list than that value so the formula never gets populated.

I'd need to go through the rest of the code and your previous thread to figure out why the code is set up to apply a formula anyway - it may just be a case of skipping the formula in such cases.

 

[Woodpusher147]

Thank you for looking.
Could it just be changed to less than 9 i.e >3
not sure if that would mess up anything else.
Sorry to be so oblivious to this stuff

 

[Woodpusher147]

Basically the sheet has to score based on colour of cell
Gold = 5
Green= 3
Amber = 1
Red = 0
Each column has different criteria which you can see in the KEY

but some of the columns would count as x4, x2, or x5 which is what this formula was created for
=SUMPRODUCT(CFV(F6:P6),IF(D6="Bedroom",{4,4,4,0,0,0,0,0,5,2,1},{4,4,4,4,1,1,2,1,0,0,1}))
Different values for bedroom needed to be made so the above formula allows me to ,multiply each column by whatever I need and have bedroom seperated.

Another complication was that the NPS column (G) needed the top 4 scores to be gold next 3 to be green, next 2 amber and rest red.
That added another block of code

LEaderboard takes results from each sheet and orders them largest to smalles then seperates by department and presents side by side.

I have just tried on the DT tab and when removing rows 1 by 1 (columns C - P) the runtime error happens after I have 10 rows left
I updated after removing row 11 and the error didnt happen but when I tried to change one of the cells and then update, the runtime errer appeared. Debug was same line highlighted

Does that help ?

 

[Woodpusher147]

@RoryA I have just spotted something that relates to the >9 that you mentioned
The column which relates to NPS (G) is causing the issue because the code section that refers to >9 fails for a reason I cant see
If I make all records 100 which makes them all gold so all share top place, it fails but if I make them all different figures then the code runs again with no runtime error

I really don't know how to fix this but hopefully someone here will know easily

PLEase

 

[RoryA]

Yes, as I mentioned, the problem is that the code doesn't bother creating a valid formula in the >9 case (because there are only 7 distinct values) but it does try to apply the invalid formula afterwards.

I've just waded through the thread you linked to, and it doesn't actually mention the code that is causing the problem, so wasn't much help to me.

Can you explain in words what is supposed to happen to that column? It looks like some sort of ranking system (4 top scores, next 3, next 2, then everything else), in which case it should be sufficient to just ignore a formula where there aren't enough valid scores.

 

[Woodpusher147]

Yes, as I mentioned, the problem is that the code doesn't bother creating a valid formula in the >9 case (because there are only 7 distinct values) but it does try to apply the invalid formula afterwards.

I've just waded through the thread you linked to, and it doesn't actually mention the code that is causing the problem, so wasn't much help to me.

Can you explain in words what is supposed to happen to that column? It looks like some sort of ranking system (4 top scores, next 3, next 2, then everything else), in which case it should be sufficient to just ignore a formula where there aren't enough valid scores.

HI

Thanks a lot for looking once more.
Yes, you are exactly right about the ranking of that column.
It wasn't mentioned in the original thread as it was added on later due to the NPS column having scores that were difficult to rank numerically as above and betweenY etc so we decided to just make the top 4 gold and so on.

This would be great if I could do something to ignore the error and it doesn't change the rankings.

HOw would I do this?


Thanks