I am currently working on a code for data validation. The excel colors the cells that are entered incorrectly (orange for wrong range, red for wrong datatype). I first used message boxes to show the wrong values but when I have a lot of entries it is annoying to all click all of them away. My new idea would be to save all the errors as Strings in a dynamic array, which i can print out in a loop at the end and show all at once. Unfortunately, I am a beginner in vba and dont know if this idea is even possible to execute. How could I implement this idea?
Sub CheckColumns()
Dim rng As Range
Dim lCol As Long, lRow As Long
Dim DblLengthMin As Double
'Dim dynamicArray() As String
'Dim f As Integer
DblLengthMax = 20000
DblLengthMin = 5
lCol = Range("C2").End(xlToRight).Column
lRow = Range("C2").End(xlDown).Row
For Each rng In Range("C2", Cells(lRow, lCol))
If IsNumeric(rng) = False Then
rng.Interior.ColorIndex = 3
'Array Entry: "A number has to be entered " & "Row " & rng.Row & " Column " &
'rng.Column
End If
If IsNumeric(rng) And rng.Value > DblLengthMax Or rng.Value < DblLengthMin Then
rng.Interior.ColorIndex = 46
'ArrayEntry "Value in " & "Row " & rng.Row & " Column " & rng.Column & " is out of
'range. Check for unit (mm)"
End If
Next rng
' Print out an extra window that shows the number of mistakes made and a list of them
and their place in their worksheet
End Sub
CodePudding user response：
I might recommend you to save all cells addresses with errors in one string variable with separator, and what is wrong in the other string variable. For example:
Dim strErrorAdress as String
Dim strError as String
For Each rng In Range("C2", Cells(lRow, lCol))
If IsNumeric(rng) = False Then
rng.Interior.ColorIndex = 3
If strErrorAdress = "" Then
strErrorAdress = rng.address & "/"
strError = "A number has to be entered" & "/"
Else
strErrorAdress =strErrorAdress & "/" & rng.address & "/"
strError = strError & "/" & "A number has to be entered" & "/"
End if
End If
If IsNumeric(rng) And rng.Value > DblLengthMax Or rng.Value < DblLengthMin Then
rng.Interior.ColorIndex = 46
If strErrorAdress = "" Then
strErrorAdress = rng.address & "/"
strError = "A number has to be entered" & "/"
Else
strErrorAdress =strErrorAdress & "/" & rng.address & "/"
strError = strError & "/" & "range. Check for unit (mm)" & "/"
End if
End If
Next rng
'Afterr all code delete last "/" in strings with
strErrorAdress = Left(strErrorAdress , Len(strErrorAdress ) - 1)
strError = Left(strError , Len(strError ) - 1)
'Then make arrays with split function
Dim arrSplitstrError() As String
Dim arrSplitstrErrorAdress() As String
arrSplitstrError = Split(strError , "/")
arrSplitstrErrorAdress = Split(strErrorAdress , "/")
'Now print errors like
dim counter as long
For counter = 0 to UBound(arrSplitstrError)
debug.print arrSplitstrErrorAdress(counter) & " - " & arrSplitstrError(counter) & vbNewLine
next counter
I'm not an expert, maybe there is a mistake in the code but the idea should be understood.
CodePudding user response：
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