Excel vba 中的動態數組可保存數據輸入中的錯誤

Question

我目前正在研究用於數據驗證的代碼。 excel colors 輸入錯誤的單元格（橙色表示錯誤范圍，紅色表示錯誤數據類型）。 我首先使用消息框來顯示錯誤的值，但是當我有很多條目時，全部單擊它們會很煩人。 我的新想法是將所有錯誤作為字符串保存在動態數組中，我可以在最后循環打印並一次顯示所有錯誤。 不幸的是，我是 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

數據示例

Answer 1

我可能會建議您將所有有錯誤的單元格地址保存在一個帶分隔符的字符串變量中，以及另一個字符串變量中的錯誤。 例如：

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

我不是專家，也許代碼中有錯誤，但應該理解這個想法。

Answer 2

為不符合條件的單元格創建報告

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