Re: VBA Highlight Rows Based on Name Count

Couple of things. First you convert the table into a range, since the whole data need to sort first. 3 column Table between the range create problem while sorting. Also I found some formulas in between the data. After doing these changes, run the macro.

[vb]Option Explicit

Sub AuditHighlights()

Dim k, dic As Object, r As Range, i As Long, p As Long

Dim j As Long, n As Long, wf As WorksheetFunction

Dim c(1) As Long, m As Long, dicRatio As Object

Set dic = CreateObject("scripting.dictionary")

dic.comparemode = 1

Set dicRatio = CreateObject("scripting.dictionary")

dicRatio.comparemode = 1

Set wf = Application.WorksheetFunction

With Worksheets("Raw Data")

Set r = .Cells(1).CurrentRegion.Resize(, 14)

k = .Range("u1").CurrentRegion.Value2 'director count

End With

For i = 2 To UBound(k, 1)

If Not IsError(k(i, 1)) Then

dicRatio.Item(k(i, 1)) = Array(k(i, 2), wf.Round(k(i, 3), 0))

End If

Next

With r

.Sort .Cells(2, 10), xlAscending, Header:=xlYes 'sort by director

.Interior.ColorIndex = -4142

k = .Value

For i = 2 To .Rows.Count

If Not IsError(k(i, 10)) Then dic.Item(k(i, 10)) = i

Next

k = Array(dic.keys, dic.items)

c(0) = 65535 'yellow

c(1) = 65280 'green

p = 1

For i = 0 To UBound(k(0))

If i Then p = k(1)(i - 1)

m = dicRatio.Item(k(0)(i))(0)

dic.RemoveAll

j = 1

Do While j <= dicRatio.Item(k(0)(i))(1)

n = wf.RandBetween(1, m)

If Not dic.exists(n) Then

.Rows(p + n).Interior.Color = c(i Mod 2)

dic.Item(n) = n

j = j + 1

End If

Loop

Next

End With

End Sub[/vb]