in Every cell in a Selection I need to replace a combination of characters. But before a replacement I want to count every combination.
The problem is that CountIf function won't count at all. Though replacement performs.
Here is a code:
Option Explicit
Sub sdfsdf()
Dim rng As Range
Dim i As Integer
Dim Cell As Range
Dim Counter As Variant
'Application.Run "Personal.xlsb!Main"
Set rng = Selection
Set Cell = Cell
Let i = 1
For Each Cell In Selection
Let Counter = Application.WorksheetFunction.CountIf(Cell, i & "&")
Cell.Replace What:=i & "&", Replacement:=""
i = i + 1
Next Cell
MsgBox Counter
End Sub
A snippet of a column with combinations to delete. I need to delete 1&, 2&, 3& and so on.
Remove Characters
Sub RemoveChars()
Const Criteria As String = "&"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range
Set rg = ws.Range("U2", ws.Cells(ws.Rows.Count, "U").End(xlUp))
' Or:
'Set rg = Selection
Dim Cell As Range
Dim Position As Long
Dim cCount As Long
Dim cString As String
For Each Cell In rg.Cells
cString = CStr(Cell.Value)
Position = InStr(1, cString, Criteria)
If Position > 0 Then ' criteria found; replace with chars to the right
Cell.Value = Mid(cString, Position + 1, Len(cString) - Position)
cCount = cCount + 1
'Else ' criteria not found; do nothing
End If
Next Cell
MsgBox "Cells processed: " & cCount, vbInformation
End Sub
Related
Can you help me with this Please, I'm trying to check if from range ("L2") to the end if result = "-" pop up a msgbox & colorize the range.
the conditions is all the cells value in the range horizontally must be = "-"
Example of what I mean:
I try to the below code but it's colorized all the value ("-") in the range
Sheets("Cumulated BOM").Activate
Dim i As Long
Dim c As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("L2", Range("L" & Row.Count).End(xlUp))
For Each myCell In myRange
c = c + 1
If (myCell) = "-" Then
myCell.Interior.Color = RGB(255, 87, 87)
i = i + 1
End If
Next myCell
Highlight Rows With All Their Cells Containing the Same Value
Option Explicit
Sub HighlightInvalidRows()
' Prepare.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Cumulated BOM")
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
' Write the number of columns of the range to a variable ('CellsCount').
Dim CellsCount As Long: CellsCount = rg.Columns.Count
' Each row of the range has this number of columns (cells).
' Remove all range colors.
rg.Interior.Color = xlNone
' Combine the rows ('rrg') to be highlighted
' into the Highlight range ('hrg').
' Declare variables that appear for the first time in the following loop.
Dim hrg As Range
Dim rrg As Range
Dim MatchCount As Long
' Loop through the rows of the range.
For Each rrg In rg.Rows
' Write the number of appearances of the value in the current row
' to a variable ('MatchCount').
MatchCount = Application.CountIf(rrg, "-")
' Compare the match count with the cells count.
If MatchCount = CellsCount Then ' the numbers are equal
' Combine the current row into the highlight range.
If hrg Is Nothing Then ' the first match
Set hrg = rrg
Else ' all other matches
Set hrg = Union(hrg, rrg)
End If
'Else ' the numbers are not equal; do nothing
End If
Next rrg
' Highlight the rows (in one go) and inform.
If hrg Is Nothing Then ' no matches found
MsgBox "No invalid rows found.", vbInformation
Else ' matches found
hrg.Interior.Color = RGB(255, 87, 87)
MsgBox "Invalid rows highlighted.", vbExclamation
End If
End Sub
How can I auto fill a column down, e.g., Cell(A1).value = dog and Cell(A12).value = Pen
How do I fill down A2:A11 with the value = dog and the A13 value = pen without manually selecting the column?
Sub filldown_example()
Dim missingcells as range
Dim fillsedcells as range
Set missingcells = select
For each filledcells in missingcells
If filledcells = "" Then
filledcells.filldown
End If
Next filledcells
End sub
No need to loop here.
Sub fillit()
With Range("a1:a13")
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value 'formula to value
End With
End Sub
You do not need VBA for this. If you search Google for Excel fill all blanks with cell above you will get the non-VBA method.
If you still want VBA, then try this. You do not need to loop through all cells.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A and add 1 to it
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Find the blank cells
On Error Resume Next
Set rng = .Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
'~~> Add the formula to get values from the above cell in 1 go
If Not rng Is Nothing Then rng.FormulaR1C1 = "=R[-1]C"
'~~> Convert formulas to values
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
In Action:
Fill Down Selection
This will allow you to select multiple ranges with multiple columns to fill down each of them.
Range
Sub FillDownSelectionRange()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim rg As Range: Set rg = Selection
Dim arg As Range ' Area Range
Dim crg As Range ' Column Range
Dim rCell As Range ' Row Cell Range
Dim rValue As Variant
For Each arg In rg.Areas
For Each crg In arg.Columns
If crg.Rows.Count > 1 Then
For Each rCell In crg.Cells
If Len(CStr(rCell.Value)) = 0 Then
rCell.Value = rValue
Else
If rCell.Value <> rValue Then
rValue = rCell.Value
End If
End If
Next rCell
End If
rValue = Empty
Next crg
Next arg
End Sub
Array
To speed up, instead of looping through the cells, you could loop through an array.
Sub FillDownSelectionArray()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim rg As Range: Set rg = Selection
Dim arg As Range ' Area Range
Dim crg As Range ' Column Range
Dim cData As Variant ' Column Array
Dim rValue As Variant
Dim r As Long
For Each arg In rg.Areas
For Each crg In arg.Columns
If crg.Rows.Count > 1 Then
cData = crg.Value
For r = 1 To UBound(cData, 1)
If IsEmpty(cData(r, 1)) Then
cData(r, 1) = rValue
Else
If cData(r, 1) <> rValue Then
rValue = cData(r, 1)
End If
End If
Next r
crg.Value = cData
End If
rValue = Empty
Next crg
Next arg
End Sub
I have a loop that goes through two-dimensional range
set rng = Range("A1:C3")
For each cell in rng
Debug.Print cell.value
next cell
It prints like:
A1
B1
C1
A2
B2...
I would prefer:
A1
A2
A3
B1
B2...
I know there is a way to do that looping with indexes but for each is much more elegant and on the top of that my range can be non-contiguous like:
Range("A1:C3,G9:H16,B14:D18")
Is there a way how to change default (horizontal) excel behavior?
Loop Through the Cells of a Non-Contiguous Range (Multi-Range)
By Areas
The numbers in the yellow cells in the image are illustrating the looping order by areas and by rows. The results of the procedures in the J and K columns are copied from the Immediate window and are showing both of the looping orders.
Option Explicit
Sub WriteCellsByAreaRows()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim mrg As Range: Set mrg = ws.Range(sAddress)
Dim arg As Range
Dim aCell As Range
For Each arg In mrg.Areas
For Each aCell In arg.Cells
Debug.Print aCell.Address(0, 0) & " = " & aCell.Value
Next aCell
Next arg
End Sub
Sub WriteCellsByAreaColumns()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim mrg As Range: Set mrg = ws.Range(sAddress)
Dim arg As Range
Dim acrg As Range
Dim aCell As Range
For Each arg In mrg.Areas
For Each acrg In arg.Columns
For Each aCell In acrg.Cells
Debug.Print aCell.Address(0, 0) & " = " & aCell.Value
Next aCell
Next acrg
Next arg
End Sub
EDIT
Area Independent (The Challenge)
The numbers in the yellow cells in the image are illustrating the looping order by rows. The results of the procedures in the J and K columns are copied from the Immediate window and are showing both of the looping orders.
Short Function Description (By Columns)
It will loop through the columns of each area and write the column number to an Array List which will finally be sorted. When looping through the elements of the Array List (each column number), a reference to the intersection of the worksheet column and the initial multi-range will be created and each single range reference will be written to an array. The array will be (bubble) sorted by the row numbers of every single column range and then will be added as an element of the resulting array of arrays.
Sub WriteCellsByColumn()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
On Error Resume Next
Dim mrg As Range: Set mrg = ws.Range(sAddress)
On Error GoTo 0
If mrg Is Nothing Then Exit Sub
Dim ColumnRanges As Variant: ColumnRanges = GetSortedColumnRanges(mrg)
If IsEmpty(ColumnRanges) Then Exit Sub ' e.g. 'ArrayList' is not working
Dim cCell As Range
Dim a As Long
Dim b As Long
For a = 0 To UBound(ColumnRanges)
For b = 0 To UBound(ColumnRanges(a))
For Each cCell In ColumnRanges(a)(b).Cells
Debug.Print cCell.Address(0, 0) & " = " & cCell.Value
Next cCell
Next b
Next a
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the sorted column range references of a range ('mrg')
' in an array of arrays.
' Remarks: Supports non-contiguous ranges (multi-ranges).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSortedColumnRanges( _
ByVal mrg As Range) _
As Variant
If mrg Is Nothing Then Exit Function
On Error Resume Next ' The ArrayList needs 'Microsoft .NET Framework 3.5'.
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
On Error GoTo 0
If arl Is Nothing Then Exit Function
Dim arg As Range ' Area (Single) Range
Dim crg As Range ' Column Range (in Area Range)
Dim cColumn As Long ' Column Number (of Column Range)
For Each arg In mrg.Areas
For Each crg In arg.Columns
cColumn = crg.Column
If Not arl.Contains(cColumn) Then
arl.Add cColumn
End If
Next crg
Next arg
arl.Sort
' Create a reference to the worksheet ('ws').
Dim ws As Worksheet: Set ws = mrg.Worksheet
' Define the Multi Range Array ('mrgArr').
Dim mrgArr As Variant: ReDim mrgArr(0 To arl.Count - 1)
Dim icrg As Range ' Intersect Column Range (in Worksheet Column)
Dim trg As Range ' Temp Range
Dim trgArr() As Range ' Temp Range Array
Dim Key As Variant '
Dim aUpper As Long
Dim a As Long
Dim b As Long
Dim n As Long
For Each Key In arl
Set icrg = Intersect(mrg, ws.Columns(Key))
aUpper = icrg.Areas.Count - 1
If aUpper = 0 Then
' Write current Intersect Row Range reference to Temp Range Array.
ReDim trgArr(0 To 0): Set trgArr(0) = icrg
Else
' Write current Intersect Row Range references to Temp Range Array.
ReDim trgArr(0 To aUpper)
For a = 0 To aUpper
Set trgArr(a) = icrg.Areas(a + 1)
Next a
' (Bubble) Sort the references by rows.
For a = 0 To aUpper - 1
For b = a To aUpper
If trgArr(a).Row > trgArr(b).Row Then
Set trg = trgArr(a)
Set trgArr(a) = trgArr(b)
Set trgArr(b) = trg
End If
Next b
Next a
End If
' Write the current Temp Range Array to the current element
' of the Multi Range Array.
mrgArr(n) = trgArr
n = n + 1
Next Key
GetSortedColumnRanges = mrgArr
End Function
Sub WriteCellsByRow()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
On Error Resume Next
Dim mrg As Range: Set mrg = ws.Range(sAddress)
On Error GoTo 0
If mrg Is Nothing Then Exit Sub
Dim RowRanges As Variant: RowRanges = GetSortedRowRanges(mrg)
If IsEmpty(RowRanges) Then Exit Sub ' e.g. 'ArrayList' is not working
Dim rCell As Range
Dim a As Long
Dim b As Long
For a = 0 To UBound(RowRanges)
For b = 0 To UBound(RowRanges(a))
For Each rCell In RowRanges(a)(b).Cells
Debug.Print rCell.Address(0, 0) & " = " & rCell.Value
Next rCell
Next b
Next a
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the sorted row range references of a range ('mrg')
' in an array of arrays.
' Remarks: Supports non-contiguous ranges (multi-ranges).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSortedRowRanges( _
ByVal mrg As Range) _
As Variant
If mrg Is Nothing Then Exit Function
On Error Resume Next ' The ArrayList needs 'Microsoft .NET Framework 3.5'.
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
On Error GoTo 0
If arl Is Nothing Then Exit Function
Dim arg As Range ' Area (Single) Range
Dim rrg As Range ' Row Range (in Area Range)
Dim cRow As Long ' Row Number (of Row Range)
For Each arg In mrg.Areas
For Each rrg In arg.Rows
cRow = rrg.Row
If Not arl.Contains(cRow) Then
arl.Add cRow
End If
Next rrg
Next arg
arl.Sort
' Create a reference to the worksheet ('ws').
Dim ws As Worksheet: Set ws = mrg.Worksheet
' Define the Multi Range Array ('mrgArr').
Dim mrgArr As Variant: ReDim mrgArr(0 To arl.Count - 1)
Dim irrg As Range ' Intersect Row Range (in Worksheet Row)
Dim trg As Range ' Temp Range
Dim trgArr() As Range ' Temp Range Array
Dim Key As Variant '
Dim aUpper As Long
Dim a As Long
Dim b As Long
Dim n As Long
For Each Key In arl
Set irrg = Intersect(mrg, ws.Rows(Key))
aUpper = irrg.Areas.Count - 1
If aUpper = 0 Then
' Write current Intersect Row Range reference to Temp Range Array.
ReDim trgArr(0 To 0): Set trgArr(0) = irrg
Else
' Write current Intersect Row Range references to Temp Range Array.
ReDim trgArr(0 To aUpper)
For a = 0 To aUpper
Set trgArr(a) = irrg.Areas(a + 1)
Next a
' (Bubble) Sort the references by rows.
For a = 0 To aUpper - 1
For b = a To aUpper
If trgArr(a).Column > trgArr(b).Column Then
Set trg = trgArr(a)
Set trgArr(a) = trgArr(b)
Set trgArr(b) = trg
End If
Next b
Next a
End If
' Write the current Temp Range Array to the current element
' of the Multi Range Array.
mrgArr(n) = trgArr
n = n + 1
Next Key
GetSortedRowRanges = mrgArr
End Function
Maybe
Sub Test()
Dim rng As Range, rRow As Range, rCol As Range
Set rng = Range("A1:C3")
For Each rCol In rng.Columns
For Each rRow In rCol.Cells
Debug.Print rRow.Value
Next rRow
Next rCol
End Sub
As a proof-of-concept with non-contiguous ranges that may overlap. Determine the lowest row and right most column of the areas, create a array that encloses all those areas, and fill it with the cell addresses of the cells in each area. Then traverse the array horizontally or vertically skipping over the blank entries.
Option Explicit
Sub demo_by_column()
Dim ar, a, cell As Range, rng As Range, i As Long
Dim rmax As Long, cmax As Long, rmin As Long, cmin As Long
Dim r As Long, c As Long
rmin = Rows.Count
cmin = Columns.Count
' non-contiguous range
Set rng = Sheet1.Range("A1:C3,D9:H16,B14:D18,A21:J21")
' dimension an array that encloses all the areas
For Each a In rng.Areas
r = a.Row + a.Rows.Count - 1
If r > rmax Then rmax = r
If a.Row < rmin Then rmin = a.Row
c = a.Column + a.Columns.Count - 1
If c > cmax Then cmax = c
If a.Column < cmin Then cmin = a.Column
Next
ReDim ar(1 To rmax, 1 To cmax)
' fill array with cell addresses
For Each a In rng.Areas
For Each cell In a
ar(cell.Row, cell.Column) = cell.Address
Next
Next
' loop the array by column, result to sheet2
i = 1
For c = cmin To cmax
For r = rmin To rmax
If Len(ar(r, c)) > 0 Then
Sheet2.Cells(i, 1) = Sheet1.Range(ar(r, c))
i = i + 1
End If
Next
Next
' show array on sheet3
Sheet3.Range("A1").Resize(rmax, cmax) = ar
End Sub
I'm trying to do a macro to produce a list based on a lookup list. For some reason the outer loop doesnt work, it only iterates once.
Sub Macro5()
Dim LookupRng As Range
Dim Store As String
Dim jrow As Integer
Dim irow As Integer
Dim i As Integer
Dim j As Integer
Set LookupRng = Sheet1.Range("B2") ' The Lookup range
jrow = Sheet2.Range("T" & Rows.Count).End(xlUp).Row ' last row of list of values to be searched
irow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row ' last row of lookup range
Sheet3.Range("A2:A" & Rows.Count).Clear
For j = 2 To jrow
Store = Sheet2.Cells(j, 20).Value ' the value to be searched in the lookup range
For i = 1 To irow
If LookupRng.Value = Store Then
Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = LookupRng.Offset(0, -1).Value
End If
Set LookupRng = LookupRng.Offset(1, 0)
Next i
Next j
The i loop works, it searches all values that match "Store", but for some reason the j loop doesnt seem to be working, it doesnt jump to the next value of the "Store" list.
I'm new to this so would prefer a simple solution, but any help will be very appreciated
Loops with Offset
The issue was that you are not resetting the Lookup Range to the initial position after each inner loop finishes. So the following loops were trying to compare the values below the Lookup Range which were empty.
You should abandon the idea of 'offsetting' and use Cells or Range and increase the rows or define the range and use a For Each loop. But the best would be to use only one loop and use Application.Match to find a match.
A Quick Fix
Option Explicit
Sub lookupLoop()
Dim ilCell As Range ' Initial Lookup Cell Range
Dim lCell As Range ' Lookup Cell Range
Dim dCell As Range ' Destination Cell Range
Dim Store As Variant ' Current Value in Search Range
Dim iRow As Long ' Last Row of Lookup Range
Dim jRow As Long ' Last Row of Search Range
Dim i As Long ' Lookup Range Rows Counter
Dim j As Long ' Search Range Rows Counter
Set ilCell = Sheet1.Range("B2")
iRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
jRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For j = 2 To jRow
Store = Sheet2.Cells(j, "T").Value
Set lCell = ilCell '***
For i = 2 To iRow
If lCell.Value = Store Then
dCell.Value = lCell.Offset(0, -1).Value
Set dCell = dCell.Offset(1)
Exit For
End If
Set lCell = lCell.Offset(1)
Next i
Next j
End Sub
An Application.Match solution might look like this:
Sub lookupAM()
Dim lrg As Range ' Lookup Range (Read)
Dim vrg As Range ' Values Range (Write)
Dim srg As Range ' Search Range
Dim sCell As Range ' Current Cell in Search Range
Dim dCell As Range ' Current Cell in Destination Range
Dim cMatch As Variant ' Current Match
Dim lRow As Long ' Last Row of Lookup Range
Dim sRow As Long ' Last Row of Search Range
lRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Set lrg = Sheet1.Range("B2:B" & lRow)
Set vrg = lrg.Offset(, -1)
sRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Set srg = Sheet2.Range("T2:T" & sRow)
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For Each sCell In srg.Cells
cMatch = Application.Match(sCell.Value, lrg, 0)
If IsNumeric(cMatch) Then
dCell.Value = vrg.Cells(cMatch).Value
End If
Set dCell = dCell.Offset(1)
Next sCell
End Sub
I am attempting to build a loop that searches through headers and finds a contained value, In this case, "Avg". If the value is found it will work down the column and apply a format based on a comparison to another column. I am trying to convert my cell variable in the For loop (Z) into a column address so I can use to control my ws.Cells() value in the next loop.
Any help is greatly appreciated, thanks!!!!
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim Z As Range
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
For Each Z In Range("I1:BM1").Cells
If InStr(1, Z.Value, "Avg") Then
For i = 2 To lastRow 'loop from row 2 to last
If ws.Cells(i, 8) - ws.Cells(i, Z) < 0 Then
ws.Cells(i, Z).Interior.ColorIndex = 4
End If
Next i
End If
Next Z
End Sub
It's not exactly clear to me what you want - but from the title it appears you want to get the column number based on the header text? If so, this will do that:
Private Function GetColumn(headerName As String) As Integer
Dim col As Integer
GetColumn = 0
For col = 1 To ActiveSheet.UsedRange.Columns.Count
If ActiveSheet.Cells(1, col).Value = headerName Then
GetColumn = col
Exit For
End If
Next col
End Function
Find Header and Format Cells
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a column range specified by its header,
' highlights the cells matching a condition.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub HighlightBelowAverages()
' Define constants.
Const PROC_TITLE As String = "Highlight Below-Averages"
Const COMPARE_COLUMN As String = "H"
Const AVG_SEARCH_COLUMNS As String = "I:BM"
Const AVG_COLUMN_HEADER As String = "Avg"
Const AVG_COLOR_INDEX As Long = 4 ' Bright Green
' Reference the Search range.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim srg As Range
' It is NOT assumed that the used range starts in row '1'.
Set srg = Intersect(ws.UsedRange, ws.Range(AVG_SEARCH_COLUMNS))
If srg Is Nothing Then
MsgBox "The Average search columns '" & AVG_SEARCH_COLUMNS _
& "' are not part of the used range.", vbCritical, PROC_TITLE
Exit Sub
End If
' Find the Average header cell.
Dim ahCell As Range
With srg
Set ahCell = .Find(AVG_COLUMN_HEADER, _
.Cells(.Rows.Count, .Columns.Count), xlFormulas, xlWhole, xlByRows)
End With
If ahCell Is Nothing Then
MsgBox "Header '" & AVG_COLUMN_HEADER & "' not found.", _
vbCritical, PROC_TITLE
Exit Sub
End If
' Reference the Average (single-column) range.
Dim afCell As Range: Set afCell = ahCell.Offset(1)
Dim alCell As Range
Set alCell = Intersect(srg.Rows(srg.Rows.Count), ws.Columns(ahCell.Column))
' It IS assumed that the data has one row of headers.
If afCell.Row > alCell.Row Then
MsgBox "No data found.", vbCritical, PROC_TITLE
Exit Sub
End If
Dim arg As Range: Set arg = ws.Range(afCell, alCell)
' Reference the Compare (single-column) range.
Dim crg As Range
' It is NOT assumed that the used range starts in column 'A'.
Set crg = Intersect(arg.EntireRow, ws.Columns(COMPARE_COLUMN))
' Highlight the cells.
Application.ScreenUpdating = False
arg.Interior.ColorIndex = xlNone
Dim aCell As Range, cCell As Range, r As Long
For Each aCell In arg.Cells
r = r + 1
Set cCell = crg.Cells(r)
If cCell.Value < aCell.Value Then ' Compare is less than Average
aCell.Interior.ColorIndex = AVG_COLOR_INDEX
End If
Next aCell
Application.ScreenUpdating = True
' Inform.
MsgBox "Below-averages highlighted.", vbInformation, PROC_TITLE
End Sub