我目前正在编写数据验证代码。excel为输入错误的单元格着色(橙色表示错误的范围，红色表示错误的数据类型(。我最初使用消息框来显示错误的值，但当我有很多条目时，所有条目都点击掉是很烦人的。我的新想法是将所有错误保存为动态数组中的字符串，我可以在最后打印出一个循环，并一次显示所有错误。不幸的是，我是vba的初学者，不知道这个想法是否有可能执行。我该如何实现这个想法？
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
数据示例
为不匹配条件的单元格创建报告
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
我建议您将所有有错误的单元格地址保存在一个带分隔符的字符串变量中，并保存另一个字符串变量中的错误。例如：
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
我不是专家，也许代码中有错误，但应该理解这个想法。