VBA conditional formatting of rows based on cell text value - vba

Question

The order of my data from my query comes out as desired - Column A asc, Column B asc.
Code Completion Date Receipt
P81800A1 09/03/2018 167,000.00
P81800A1 14/03/2018 178,000.00
P82080A 12/03/2018 352,500.00
P83103C1 02/03/2018 570,000.00
P83103C1 02/03/2018 358,000.00
P83103C1 02/03/2018 357,500.00
P83103C1 12/03/2018 340,000.00
P83103C1 12/03/2018 457,000.00
P83103C1 13/03/2018 415,000.00
P83180C1 06/03/2018 645,000.00
P83180C1 06/03/2018 520,000.00
This means if I get a completion for P81800A1 on 15/03/18 when I refresh the data, it will go in between lines 2 and 3 of above.
I have tried to summarise my goal in the attached image.
I want to VBA Conditional format each row based on the cell value of A in that row. Ie P81800A1 rows have one colour. All distinct codes have the same colour. The actual colour does not matter.
I want to do it in VBA so it is robust. I do not want to be creating any additional columns and basing it on formula in standard conditional formatting.

Answer 1

So this is not perfect but a reasonable start. It uses a dictionary to collect the unique codes and randbetween with dictionary item count to generate an associated colour. Conditional formatting rules are applied using the distinct codes.
Notes:
You might want to improve the random colour generation part (at present range is limited and you may occasionally get very dark formats - though you could run the macro again)
Make range selection more robust as start position is hard coded at present and later parts of code use this start position as well
Required, for early binding, reference to Microsoft scripting runtime to be added via VBE>Tools>References. I have included one example of how to use late binding (commented out). If using late binding you would need to specify Object instead of Dictionary for parameters and function return types (where dictionary returned).
Assumes data starts in A2 at present (sheet 9)
Option Explicit
Public Sub FormatMatchingCodes()
Dim wb As Workbook
Dim wsTarget As Worksheet
Set wb = ThisWorkbook
Set wsTarget = wb.Worksheets("Sheet9") 'change as appropriate
Dim lastRow As Long
Application.ScreenUpdating = False
lastRow = GetLastRow(wsTarget)
Dim formatRange As Range
If Not lastRow <= 2 Then
Set formatRange = wsTarget.Range("A2:C" & lastRow) 'Excludes header row
Else
MsgBox "End row is before start row"
Exit Sub
End If
Dim codeColoursDictionary As Dictionary
Set codeColoursDictionary = GetDistinctCodeCount(formatRange.Value2)
wsTarget.Cells.FormatConditions.Delete
AddFormatting formatRange, codeColoursDictionary
Application.ScreenUpdating = True
End Sub
Public Function GetDistinctCodeCount(ByVal sourceData As Variant) As Dictionary 'as object if latebound
''LATE binding
' Dim distinctDict As Object
' Set distinctDict = CreateObject("Scripting.Dictionary")
''Early binding add reference to VBE > tools > references > Microsoft scripting runtime
Dim distinctDict As Scripting.Dictionary
Set distinctDict = New Scripting.Dictionary
Dim currentCode As Long
For currentCode = LBound(sourceData, 1) To UBound(sourceData, 1)
If Not distinctDict.exists(sourceData(currentCode, 1)) Then
distinctDict.Add sourceData(currentCode, 1), Application.WorksheetFunction.RandBetween(13434828, 17777777) + distinctDict.Count
End If
Next currentCode
Set GetDistinctCodeCount = distinctDict
End Function
Public Function GetLastRow(ByVal wsTarget As Worksheet) As Long
With wsTarget
GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).row 'change to column containing last row up to which you want to format
End With
End Function
Public Sub AddFormatting(ByVal formatRange As Range, ByVal codeColoursDictionary As Dictionary) 'note pass as object if late binding
Dim key As Variant
Dim counter As Long
For Each key In codeColoursDictionary.Keys
counter = counter + 1
With formatRange
.FormatConditions.Add Type:=xlExpression, Formula1:="=$A2=""" & key & """"
.FormatConditions(counter).StopIfTrue = False
With .FormatConditions(counter).Interior
.PatternColorIndex = xlAutomatic
.Color = codeColoursDictionary(key)
' .TintAndShade = 0
End With
End With
Next key
End Sub
Data in sheet after run:
Version 2 for OP
Option Explicit
Public Sub FormatMatchingCodes2()
Dim wb As Workbook
Dim wsTarget As Worksheet
Set wb = ThisWorkbook
Set wsTarget = wb.Worksheets("Sheet9") 'change as appropriate
Dim lastRow As Long
Application.ScreenUpdating = False
lastRow = GetLastRow(wsTarget)
Dim formatRange As Range
If Not lastRow <= 2 Then
Set formatRange = wsTarget.Range("A2:G" & lastRow) 'Excludes header row
Else
MsgBox "End row is before start row"
Exit Sub
End If
Dim codeColoursDictionary As Dictionary
Set codeColoursDictionary = GetDistinctCodeCount(formatRange.Value2)
wsTarget.Cells.FormatConditions.Delete
AddFormatting formatRange, codeColoursDictionary
Application.ScreenUpdating = True
End Sub
Public Function GetDistinctCodeCount(ByVal sourceData As Variant) As Dictionary 'as object if latebound
''LATE binding
' Dim distinctDict As Object
' Set distinctDict = CreateObject("Scripting.Dictionary")
''Early binding add reference to VBE > tools > references > Microsoft scripting runtime
Dim distinctDict As Scripting.Dictionary
Set distinctDict = New Scripting.Dictionary
Dim currentCode As Long
For currentCode = LBound(sourceData, 1) To UBound(sourceData, 1)
If Not distinctDict.exists(sourceData(currentCode, 5)) Then
distinctDict.Add sourceData(currentCode, 5), Application.WorksheetFunction.RandBetween(13434828, 17777777) + distinctDict.Count
End If
Next currentCode
Set GetDistinctCodeCount = distinctDict
End Function
Public Function GetLastRow(ByVal wsTarget As Worksheet) As Long
With wsTarget
GetLastRow = .Cells(.Rows.Count, "E").End(xlUp).row 'change to column containing last row up to which you want to format
End With
End Function
Public Sub AddFormatting(ByVal formatRange As Range, ByVal codeColoursDictionary As Dictionary) 'note pass as object if late binding
Dim key As Variant
Dim counter As Long
For Each key In codeColoursDictionary.Keys
counter = counter + 1
With formatRange
.FormatConditions.Add Type:=xlExpression, Formula1:="=$E2=""" & key & """"
.FormatConditions(counter).StopIfTrue = False
With .FormatConditions(counter).Interior
.PatternColorIndex = xlAutomatic
.Color = codeColoursDictionary(key)
' .TintAndShade = 0
End With
End With
Next key
End Sub