Create a Report For Cells Not Matching Criteria
Option Explicit
Sub CheckColumns()
' Define constants.
Const sName As String = "Sheet1"
Const sfCol As Long = 3
Dim dHeaders() As Variant: dHeaders = VBA.Array( _
"Id", "Mistake", "Value", "Row", "Column", "Action Needed")
Const gteMin As Double = 2
Const lteMax As Double = 20000
Const rColor As Long = 26367 ' a kind of orange
Const cColor As Long = 255 ' red
' Write the source data to a 2D one-based array ('sData').
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srOffset As Long: srOffset = 1
Dim srCount As Long: srCount = srg.Rows.Count - srOffset
Dim scOffset As Long: scOffset = sfCol - 1
Dim scCount As Long: scCount = srg.Columns.Count - scOffset
Dim sdrg As Range
Set sdrg = srg.Resize(srCount, scCount).Offset(1, sfCol - 1)
Dim sData() As Variant: sData = sdrg.Value
' Write the report data to 1D one-based arrays ('dDataRow')
' of a collection ('coll') and combine the cells containinig mistakes
' into ranges ('rrg','nrg').
Dim dcCount As Long: dcCount = UBound(dHeaders) + 1
Dim dDataRow() As Variant: ReDim dDataRow(1 To dcCount)
Dim coll As Collection: Set coll = New Collection
Dim rrg As Range ' not in range
Dim nrg As Range ' not a number
Dim sItem As Variant
Dim sRow As Long
Dim sCol As Long
Dim sr As Long
Dim sc As Long
Dim dr As Long
Dim IsNumber As Boolean
Dim InRange As Boolean
For sr = 1 To srCount
For sc = 1 To scCount
sItem = sData(sr, sc)
If VarType(sItem) = vbDouble Then
IsNumber = True
If sItem >= gteMin Then
If sItem <= lteMax Then
InRange = True
End If
End If
End If
If InRange Then
InRange = False
IsNumber = False
Else
dr = dr + 1
dDataRow(1) = dr
dDataRow(3) = sItem
sRow = sr + srOffset
dDataRow(4) = sRow
sCol = sc + scOffset
dDataRow(5) = sCol
If IsNumber Then
dDataRow(2) = "Not in range"
dDataRow(6) = "Check for unit (mm)"
Set rrg = RefCombinedRange(rrg, sws.Cells(sRow, sCol))
IsNumber = False
Else
dDataRow(2) = "Not a number"
dDataRow(6) = "Enter a number"
Set nrg = RefCombinedRange(nrg, sws.Cells(sRow, sCol))
End If
coll.Add dDataRow
End If
Next sc
Next sr
If coll.Count = 0 Then
MsgBox "No mistakes found.", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
' Highlight cells.
srg.Interior.Color = xlNone
If Not rrg Is Nothing Then rrg.Interior.Color = rColor ' not in range
If Not nrg Is Nothing Then nrg.Interior.Color = cColor ' not a number
' Write the report data from the arrays in the collection
' to a 2D one-based array, the destination array ('dData').
Dim drCount As Long: drCount = dr + 1 ' include headers
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim dc As Long
' Write headers.
For dc = 1 To dcCount
dData(1, dc) = dHeaders(dc - 1)
Next dc
' Write data
dr = 1 ' skip headers
For Each sItem In coll
dr = dr + 1
For dc = 1 To dcCount
dData(dr, dc) = sItem(dc)
Next dc
Next sItem
' Write the data from the destination array to a new single-worksheet
' workbook, the destination workbook ('dwb').
Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
With dwb.Worksheets(1).Range("A1").Resize(, dcCount)
.Resize(drCount).Value = dData
.Font.Bold = True
.EntireColumn.AutoFit
End With
dwb.Saved = True ' just for easy closing
Application.ScreenUpdating = True
' Inform.
MsgBox "Columns checked.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function
