VBA create names for columns - excel

So I have a worksheet called "gar_nv" containing in its first row some strings that I'd like to define as names for my columns. For instance, first cell of column A is "Number", I'd like to refer to the column A(starting from the second cell) as "Number" instead of column "A".
Sub NameCol()
Dim LastRow As Long
Dim x As Long, Rng As Range
With gar_nv
For x = 1 To .UsedRange.Columns.Count
LastRow = Cells(Cells.Rows.Count, x).End(xlUp).Row
Set Rng = Cells(2, x).Resize(LastRow)
.Names.Add Name:=Cells(1, x), RefersTo:=Rng
Set Rng = Nothing
Next
End With
End Sub
When I test my code like this, it throws a 91 error, what am I doing wrong?
Sub test()
With gar_nv
For Each Rng In .Range("Number")
MsgBox (Rng.Value)
Next
End With
End Sub

Create Names for Columns of Data
gar_nv is the code name of a worksheet in the workbook containing this code.
Option Explicit
Sub NameColumnsData()
' Delete all previous names in the worksheet.
'DeleteAllWorksheetNames gar_nv
Dim hrg As Range ' header range
Dim drg As Range ' data range
Dim cCount As Long ' number of columns
With gar_nv.UsedRange
Set hrg = .Rows(1)
Set drg = .Resize(.Rows.Count - 1).Offset(1)
cCount = .Columns.Count
End With
Dim crg As Range
Dim c As Long
Dim cTitle As String
For c = 1 To cCount
cTitle = hrg.Cells(c).Value
Set crg = drg.Columns(c)
gar_nv.Names.Add cTitle, crg
' Of course, you can lose the variables and just do:
'gar_nv.Names.Add hrg.Cells(c).Value, drg.Columns(c)
Next c
MsgBox "Column data names created.", vbInformation
End Sub
Sub NameColumnsDataTEST()
Dim cCell As Range
With gar_nv
For Each cCell In .Range("Number").Cells
' Caution! If there are many cells it may take 'forever'.
'MsgBox cCell.Address(0, 0) & ": " & cCell.Value
' Rather print to the Immediate window (Ctrl+G):
Debug.Print cCell.Address(0, 0) & ": " & cCell.Value
Next
End With
End Sub
Sub DeleteAllWorksheetNames(ByVal ws As Worksheet)
Dim nm As Name
For Each nm In ws.Names
Debug.Print nm.Name, nm.RefersTo, "Deleted!"
nm.Delete
Next nm
End Sub

Related

Trying to copy table range with criteria

Im trying to copy a table range with criteria, however I am not able to define the criteria to copy the desired lines, which consists of copying only the lines where the CC column has data skiping the entire row if CC is empty. I'll just copy ( copy to clipboard ), for paste I'll do it manually for other reasons
The lines will always be like this, never with a whole blank line between them like the second image
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For Each rng In .Range("B3:I3" & bottomA)
If WorksheetFunction.Sum(.Range("B" & rng.Row & ":I" & rng.Row)) > 0 Then
Range("B" & rng.Row & ":I" & rng.Row)).Copy
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Use Union to select a non-contiguous range.
Option Explicit
Sub CopyValues()
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, rngB As Range
Dim tbl As ListObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("CC2")
With ws.ListObjects("Tabela452")
For Each rngB In .ListColumns("CC").DataBodyRange
If Len(rngB) > 0 Then
If rng Is Nothing Then
Set rng = rngB.Resize(1, 8) ' B to I
Else
Set rng = Union(rng, rngB.Resize(1, 8))
End If
End If
Next
End With
If rng Is Nothing Then
MsgBox "Nothing selected", vbExclamation
Else
rng.Select
rng.Copy
MsgBox "range copied " & rng.Address, vbInformation
End If
End Sub
Please, test the next adapted code. It does not need any iteration:
Sub CopyValues()
Dim rngCopy As Range, tbl As ListObject
Dim srcWS As Worksheet: Set srcWS = Sheets("CC2")
Set tbl = srcWS.ListObjects(1) 'use here the table name, if more than 1
On Error Resume Next 'for the case of no any value in the table first column
Set rngCopy = tbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeConstants)
'or
'Set rngCopy = tbl.DataBodyRange.Columns(tbl.ListColumns("CC").Index).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngCopy Is Nothing Then 'for the case of no any values in table first column
Intersect(rngCopy.EntireRow, tbl.DataBodyRange).Copy
Else
MsgBox "No any value in column ""CC""..."
End If
End Sub
As I said in my comment, it works if the values in column "CC" are not result of formulas...
Copy Filtered Rows From Excel Table (ListObject)
The screenshot illustrates the benefits of using an Excel table:
The table can be anywhere on the worksheet.
You can easily reference a column by its name (header).
You can move the column anywhere in the table.
Sub CopyFilteredRows()
' Define constants.
Const WorksheetName As String = "CC2"
Const TableName As String = "Tabela452"
Const CriteriaColumnName As String = "CC"
Const Criteria As String = "<>" ' non-blanks ('blank' includes 'empty')
' Reference the objects ('wb', 'ws' , 'tbl', 'lc')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
Dim lc As ListColumn: Set lc = tbl.ListColumns(CriteriaColumnName)
' Reference the filtered rows ('rrg').
Dim rrg As Range
With tbl
If .ShowAutoFilter Then ' autofilter arrows are turned on
' Clear all filters.
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else ' autofilter arrows are turned off
.ShowAutoFilter = True ' turn on the autofilter arrows
End If
.Range.AutoFilter lc.Index, Criteria
' Attempt to reference the filtered rows ('rrg').
On Error Resume Next
' Reference the visible cells.
Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
' When columns are hidden, resize to entire rows of the table.
Set rrg = Intersect(.DataBodyRange, rrg.EntireRow)
On Error GoTo 0
' Clear the filter.
.AutoFilter.ShowAllData
End With
' Invalidate the filtered rows.
If rrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Copy.
rrg.Copy
End Sub
For the criteria when looking for empty values, you can always use LEN to check the number of characters in the cell.
If it is greater than 0 it means that something is in there, you can also set it to an exact amount of digits to be more precise.
Something like this should work:
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Dim currentRow As Long
Const ccColumn As Long = 2
Const startingRow As Long = 3
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For currentRow = startingRow To bottomA
If Len(.Cells(currentRow, ccColumn).Value) > 0 Then
.Range("B" & currentRow & ":I" & currentRow).Copy
End If
Next currentRow
End With
Application.ScreenUpdating = True
End Sub

Running VBA code across multiple sheets issue

I am currently using this code which goes through my worksheet and checks in the range O15:O300 to see if there are any cells that match the current date. If there is then it copies the entire row to worksheet "Today's Actions" then copies the site number (Situated in cell C3) to column AA in "Todays Actions".
I use the below code which works fine for this task for one specific sheet:
Sub rangecheck()
Application.ScreenUpdating = False
For Each cell In Range("O15:O300")
If cell.Value = Date Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Today's Actions").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveSheet.Range("C3").Copy
Sheets("Today's Actions").Range("AA" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
End Sub
However, there are multiple sheets that I need to action this code for. So I use the below code to run this across all sheets:
Sub rangecheck_Set()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Call rangecheck
Next
starting_ws.Activate 'activate the worksheet that was originally active ("Today's Actions")
Application.ScreenUpdating = True
End Sub
This issue I'm having is that it seems to work fine but randomly whenever there are a lot of dates that match todays date in range O15:O300, it duplicates some lines up to or slightly exceeding 300 rows (So as an example, if there were 15 rows that 'should' be brought back to "Today's action" tab, it would bring them back but then have a few other rows randomly duplicated down to around row 300).
I get this might be due to the range going down to 300 but I even edited the range to go to 'last row' and it still brings back the same issue. Any thoughts? I've been trying to solve this for days now. Any help appreciated
Don't use implicit references to worksheets and ranges. It is most likely that this is the reason for your problem.
Also you don't need to select and copy - another source for unforeseeable errors.
Another reason for your error could be that you don't exclude "Today's Actions"-sheet from the copying routine.
I re-wrote your sub that is copying the data:
Sub copyTodaysRows(wsSource As Worksheet, wsTarget As Worksheet)
If wsSource is wsTarget then Exit Sub 'don't run this for the target sheet
Dim c As Range, wsTargetNewRow As Long
For Each c In wsSource.Range("O15:O300")
If c.Value = Date Then
With wsTarget
wsTargetNewRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
c.EntireRow.Copy Destination:=.Range("A" & wsTargetNewRow)
.Range("AA" & wsTargetNewRow).Value = wsSource.Range("C3").Value
End With
End If
Next
End Sub
It takes the source sheet and the target sheet as input parameters.
You will call it like this within your "outer" routine:
Sub rangecheck_Set()
Application.ScreenUpdating = False
Dim wsSource as worksheet
Dim wsTarget as worksheet
Set wsTarget = Thisworkbook.Worksheets("Today's Actions")
For Each wsSource In ThisWorkbook.Worksheets
copyTodaysRows wsSource, wsTarget
Next
Application.ScreenUpdating = True
End Sub
Copy Values of Criteria (Dates) Rows From Multiple Worksheets
Option Explicit
Sub RetrieveTodaysActions()
' Calls 'RetrieveTodaysActionsCall'.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet
For Each sws In ThisWorkbook.Worksheets
RetrieveTodaysActionsCall sws
Next sws
MsgBox "Today's actions retrieved.", vbInformation
End Sub
Sub RetrieveTodaysActionsCall(ByVal sws As Worksheet)
' Define constants.
' Source
Const sCriteriaColumnAddress As String = "O15:O300"
Const sCol1 As String = "A"
Const sCell2Address As String = "C3"
' Destination
Const dName As String = "Today's Actions"
Const dCol1 As String = "A"
Const dCol2 As String = "AA"
' Both
' Write the criteria date to a variable ('CriteriaDate').
Dim CriteriaDate As Date: CriteriaDate = Date ' today
' Exclude the destination worksheet.
If StrComp(sws.Name, dName, vbTextCompare) = 0 Then Exit Sub
' Reference the source criteria column range ('scrg').
Dim scrg As Range: Set scrg = sws.Range(sCriteriaColumnAddress)
' Check the number of matches, the number of rows to be copied
' to the destination worksheet.
If Application.CountIf(scrg, Date) = 0 Then Exit Sub
' Reference the range ('surg'), the range from the first cell
' in the source column ('sCol1') to the last cell of the used range.
Dim surg As Range
With sws.UsedRange
Set surg = sws.Range(sCol1 & 1, .Cells(.Rows.Count, .Columns.Count))
End With
' Reference the source range ('srg').
Dim srg As Range: Set srg = Intersect(scrg.EntireRow, surg)
If srg Is Nothing Then Exit Sub
' Write the number of columns of the source range to a variable (cCount).
Dim cCount As Long: cCount = srg.Columns.Count
' Write the criteria column number to a variable ('CriteriaColumn').
Dim CriteriaColumn As Long: CriteriaColumn = scrg.Column
' Write the values from the source range to an array ('Data').
Dim Data() As Variant: Data = srg.Value
Dim sValue As Variant ' Criteria Value in the Current Source Row
Dim sr As Long ' Current Source Row
Dim c As Long ' Current Source/Destination Column
Dim dr As Long ' Current Destination Row
' Loop through the rows of the array.
For sr = 1 To UBound(Data, 1)
' Write the value in the current row to a variable.
sValue = Data(sr, CriteriaColumn)
' Check if the current value is a date.
If IsDate(sValue) Then
' Check if the current value is equal to the criteria date.
If sValue = CriteriaDate Then
dr = dr + 1
' Write the values from the source row to the destination row.
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
End If
Next sr
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(dName)
' Reference the destination first cell ('dfCell').
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol1).End(xlUp).Offset(1)
' Reference the destination range ('drg').
Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
' Write the values from the array to the destination range.
drg.Value = Data
' Reference the destination range 2 ('drg2').
Dim drg2 As Range: Set drg2 = drg.EntireRow.Columns(dCol2)
' Write the source cell 2 value to the destination range 2 ('drg2')
' (the same value to all cells of the range).
drg2.Value = sws.Range(sCell2Address).Value
End Sub
My process was different from the other responses, so I will still post it. I have also added a way of logging that a row has been logged because otherwise I saw that rows could be duplicated to the "Today's Actions" sheet.
Sub rangecheck(ByVal checkedSheet As Worksheet)
'#PARAM checkedSheet is the sheet to iterate through for like dates.
'Instantiate counter variables
Dim matchRow As Integer
matchRow = 0
Dim pasteRow As Integer
pasteRow = 0
Application.ScreenUpdating = False
For Each cell In checkedSheet.Range("O15:O300")
If cell.Value = Date Then
matchRow = cell.Row
'Checks if the row has been logged already (I use column "A" because I
'have no data in it, but this can be amy column in the row)
If checkedSheet.Cells(matchRow, 1) = "Logged" Then
'Do nothing
Else
'Sets value of "pasteRow" to one lower than the lowest used row in
column "AA"
pasteRow = Sheets("Today's Actions").Cells(Rows.Count,
27).End(xlUp).Row + 1
'Copies the values of the matchRow to the pasteRow
Sheets("Today's Actions").Rows(pasteRow).Value =
checkedSheet.Rows(matchRow).Value
'Copies the value of the Site Number to the paste row column "AA"
Sheets("Today's Actions").Cells(pasteRow, 27).Value =
checkedSheet.Cells(3, 3).Value
'Log that a row has been added to the "Today's Actions" sheet
checkedSheet.Cells(matchRow, 1) = "Logged"
End If
End If
Next
Application.ScreenUpdating = True
End Sub
I have also modifed your sub which calls the copying sub to check if it is trying to copy the "Today's Actions" sheet.
Sub rangecheck_Set()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = Worksheets("Today's Actions")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
'Check if the ws to check is "Today's Actions"
If ws.Name = "Today's Actions" Then
'Do Nothing
Else
Call rangecheck(ws)
End If
Next
starting_ws.Activate 'activate the worksheet that was originally active
Application.ScreenUpdating = True
End Sub

Delete duplicate rows based on multiple columns

Bascially I have found the below formula which is perfect except it only filters duplicates out based on column A, whereas I only want the rows deleted if Col A, B and C are all duplicated.
Sub removeDupes()
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet 'This can be changed to a specific sheet: Worksheets("sheetName")
With ws
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1
If .Cells(i, 1).Value = .Cells(i + 1, 1).Value Then
.Rows(i).Delete
End If
Next i
End With
End Sub
How can I edit this code so it applies to 3 columns?
Remove Duplicates
Before
After
Option Explicit
Sub RemoveDupesShort()
With ActiveSheet.UsedRange
.Range("A3", .Cells(.Rows.Count, .Columns.Count)) _
.RemoveDuplicates (VBA.Array(1, 2, 3))
End With
MsgBox "Duplicates removed.", vbInformation
End Sub
Sub RemoveDupes()
' Define constants.
Const FirstCellAddress As String = "A3"
Dim DupeCols() As Variant: DupeCols = VBA.Array("A", "B", "C")
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' For worksheet 'Sheet1' in the workbook containing this code, instead use:
'Set ws = ThisWorkbook.Worksheets("Sheet1")
' Reference the range ('rg').
Dim rg As Range
With ws.UsedRange
Set rg = ws.Range(FirstCellAddress, .Cells(.Rows.Count, .Columns.Count))
End With
' Write the column numbers to a zero-based variant array ('Cols').
Dim cUpper As Long: cUpper = UBound(DupeCols)
Dim Cols() As Variant: ReDim Cols(0 To cUpper)
Dim c As Long
For c = 0 To cUpper
Cols(c) = ws.Columns(DupeCols(c)).Column
Next c
' Remove duplicates.
rg.RemoveDuplicates (Cols)
' Note that the array of column numbers also needs to be evaluated:
' '(Cols)' which is short for 'Evaluate(Cols)'
' Inform.
MsgBox "Duplicates removed.", vbInformation
End Sub

How to auto fill column down in VBA

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

Finding column based on header then formatting rows

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

Resources