VBA Frequency Highlighter Function in Very Large Excel Sheet - vba

Question

In a previous post user: LocEngineer managed to help me to write a finding function that would find the least frequent values in a column of a particular category.
The VBA code works well for the most part with some particular issues, and the previous question had been answered with a sufficiently good answer already, so I thought this required a new post.
LocEngineer: "Holy smoking moly, Batman! If THAT truly is your sheet.... I'd say: forget "UsedRange". That won't work well enough with THAT spread... I've edited the above code using more hardcoded values. Please adapt the values according to your needs and try that. Woah what a mess."
Here is the code:
Sub frequenz()
Dim col As Range, cel As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long, totalRows As Long
Dim relFrequency As Double
Dim RAN As Range
RAN = ActiveSheet.Range("A6:FS126")
totalRows = 120
For Each col In RAN.Columns
'***get column letter***
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
'*******
For Each cel In col.Cells
lookFor = cel.Text
frequency = Application.WorksheetFunction.CountIf(Range(letter & "2:" & letter & totalRows), lookFor)
relFrequency = frequency / totalRows
If relFrequency <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
Next cel
Next col
End Sub
The Code is formatted like this: (Notice the merged cells that head each column for titles. The titles go down to row 5 and data starts on row 5) (Also Notice that the rows are very much filled with empty columns, sometimes more so than data.)
Finally, one important change I cant figure out is how to get it to ignore blank cells.
Please advise. Thank you.

Answer 1

If the 2 adjustments to be made are to 1. exclude headers, and 2. blank cells
Exclude the headers in way a bit more dynamic; this excludes the top 6 rows:
With ActiveSheet.UsedRange
Set ran = .Offset(6, 0).Resize(.Rows.Count - 6, .Columns.Count)
End With
In the inner For loop, after this line For Each cel In col.Cells you need an IF:
For Each cel In col.Cells
If Len(cel.Value2) > 0 Then...
Here is the modified version (untested):
Option Explicit
Sub frequenz()
Const MIN_ROW As Long = 6
Const MAX_ROW As Long = 120
Dim col As Range
Dim cel As Range
Dim rng As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long
With ActiveSheet.UsedRange
Set rng = .Offset(MIN_ROW, 0).Resize(MAX_ROW, GetMaxCell.Column)
End With
For Each col In rng.Columns
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
For Each cel In col
lookFor = cel.Value2
If Len(lookFor) > 0 Then 'process non empty values
frequency = WorksheetFunction.CountIf( _
Range(letter & "2:" & letter & MAX_ROW), lookFor)
If frequency / MAX_ROW <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
End If
Next cel
Next col
End Sub
.
Updated to use a new function when determining the last row and column containing values:
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'It returns the last cell of range with data, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End With
End If
End Function