【问题标题】：Perfect user input validation in Excel VBAExcel VBA中完美的用户输入验证
【发布时间】：2016-09-11 15:16:59
【问题描述】：

我需要在单元格更改时验证用户输入，并使用 VBA 在 Excel 的另一个单元格中显示错误。

当用户插入行或列时，我遇到了在工作表中的所有单元格上调用我的验证器的问题，这导致 Excel 长时间无响应，我该如何解决这个问题？

以下是我的要求和我当前的解决方案以及完整的文档。

定义和要求

|      |        | Tolerance |           |                            |
| Type | Length |  enabled  | Tolerance | Note                       |
|------|--------|-----------|-----------|----------------------------|
|      |      4 |         0 |           | Type is missing            |
|      |        |         0 |           | Type is missing            |
|   C  |     40 |         1 |       110 |                            |
|   D  |     50 |         1 |           | Tolerance is missing       |
|      |        |           |           |                            |

这个想法是用户在表中输入值，一旦值被更改（用户离开单元格），值就会被验证，如果有问题，错误就会打印在“注释”列中。

应该忽略空白行。

我需要它是健壮的，这意味着它不应该在任何用户输入上失败，这意味着它必须适用于以下情况：

粘贴值
删除行
插入行（空单元格或剪切单元格）
插入/删除列 *
还有什么我错过的案例吗？

*当用户删除作为表格一部分的列时验证失败是可以的，因为这被视为用户故意破坏工作表，但它必须优雅地失败（即不是通过验证所有单元格在需要很长时间的工作表中）。 如果此操作是可撤消的，那就太好了，但我目前对 Excel 的理解表明这是不可能的（在宏更改工作表中的某些内容后，无法再撤消任何操作）。

Note 单元格一次只能包含一个错误，对于用户而言，最相关的错误是用户上次更改的单元格的错误，因此它应该首先显示此错误。用户修复该错误后，顺序不再那么重要，因此它可以从左到右显示错误。

当前方法的问题

我的问题是，当插入行/列时，会为工作表中的所有单元格触发验证，这是一个非常缓慢的过程，在用户看来，程序已经崩溃，但一旦验证完成，它就会返回。我不知道 Excel 为什么会这样做，但我需要一种解决方法。

代码放置在名为“用户输入”的工作表中

我的解决方案基于我所知道的唯一 on change 事件处理程序：每张表全局 Worksheet_Change 函数（啊！）。

Worksheet_Change 函数

首先它检查更改的单元格是否与我有兴趣验证的单元格相交。这个检查其实挺快的。

OldRowCount 这里是尝试根据使用范围的变化来捕捉用户插入或删除单元格，但这只能解决某些情况并在 Excel 忘记全局变量时引入问题（这种情况不时发生，我不知道原因）以及函数第一次运行的时间。

for 循环使其适用于粘贴的值。

Option Explicit

Public OldRowCount As Long

' Run every time something is changed in the User Input sheet, it then filters on actions in the table
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRowCount As Long
    NewRowCount = ActiveSheet.UsedRange.Rows.count

    If OldRowCount = NewRowCount Then
        If Not Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE)) Is Nothing Then
            Dim myCell As Range

            ' This loop makes it work if multiple cells are changed, for example while pasting cells
            For Each myCell In Target.Cells
                ' Protect the header rows
                If myCell.row >= ROW_FIRST Then
                    checkInput_cell myCell.row, myCell.Column, Me
                End If
            Next
        End If
    ElseIf OldRowCount > NewRowCount Then
        'Row deleted, won't have to deal with this as it solves itself
        OldRowCount = NewRowCount
    ElseIf OldRowCount < NewRowCount Then
        Debug.Print "Row added, TODO: deal with this"
        OldRowCount = NewRowCount
    End If
End Sub

放置在模块中的代码

全局变量

定义要验证的行/列。

Option Explicit

' User input sheet set up
Public Const ROW_FIRST = 8
Public Const COL_TYPE = "B"
Public Const COL_LENGTH = "C"
Public Const COL_TOLERANCE_ENABLED = "D"
Public Const COL_TOLERANCE = "E"
Public Const COL_NOTE = "G"

单元格检查功能

此函数验证给定单元格，除非该单元格所在的行为空。

这意味着我们只对验证用户实际开始赋值的行上的单元格感兴趣。空行不是问题。它首先验证当前更改的单元格，如果没问题，它将验证给定行上的其他单元格（因为某些单元格验证取决于其他单元格的值，请参阅上面的示例表中启用的容差）。

注释一次只会包含一条错误消息，上述操作是为了让我们始终得到注释单元格中最后更改的单元格的错误。

是的，这将使检查器在当前单元格上运行两次，虽然这不是问题，但可以通过更复杂的 if 语句来避免，但为简单起见，我跳过了它。 p>

Sub checkInput_cell(thisRow As Long, thisCol As Long, sheet As Worksheet)
    Dim note As String
    note = ""

    With sheet
        ' Ignore blank lines
        If .Range(COL_TYPE & thisRow).value <> "" _
        Or .Range(COL_LENGTH & thisRow).value <> "" _
        Or .Range(COL_TOLERANCE_ENABLED & thisRow).value <> "" _
        Or .Range(COL_TOLERANCE & thisRow).value <> "" _
        Then

            ' First check the column the user changed
            If col2Let(thisCol) = COL_TYPE Then
                note = check_type(thisRow, sheet)
            ElseIf col2Let(thisCol) = COL_LENGTH Then
                note = check_length(thisRow, sheet)
            ElseIf col2Let(thisCol) = COL_TOLERANCE_ENABLED Then
                note = check_tolerance_enabled(thisRow, sheet)
            ElseIf col2Let(thisCol) = COL_TOLERANCE Then
                note = check_tolerance(thisRow, sheet)
            End If

            ' If that did not result in an error, check the others
            If note = "" Then note = check_type(thisRow, sheet)
            If note = "" Then note = check_length(thisRow, sheet)
            If note = "" Then note = check_tolerance_enabled(thisRow, sheet)
            If note = "" Then note = check_tolerance(thisRow, sheet)

        End If
        ' Set note string (done outside the if blank lines checker so that it will reset the note to nothing on blank lines)
        ' only change it actually set it if it has changed (optimization)
        If Not .Range(COL_NOTE & thisRow).value = note Then
            .Range(COL_NOTE & thisRow).value = note
        End If
    End With
End Sub

单个列的验证器

这些函数取一行并根据其特殊要求验证某一列。如果验证失败，则返回一个字符串。

' Makes sure that type is :
' Unique in its column
' Not empty 
Function check_type(affectedRow As Long, sheet As Worksheet) As String
    Dim value As String
    Dim duplicate_found As Boolean
    Dim lastRow As Long
    Dim i As Long
    duplicate_found = False
    value = sheet.Range(COL_TYPE & affectedRow).value
    check_type = ""

    ' Empty value check
    If value = "" Then
        check_type = "Type is missing"
    Else
        ' Check for uniqueness
        lastRow = sheet.Range(COL_TYPE & sheet.Rows.count).End(xlUp).row
        If lastRow > ROW_FIRST Then
            For i = ROW_FIRST To lastRow
                If Not i = affectedRow And sheet.Range(COL_TYPE & i).value = value Then
                    duplicate_found = True
                End If
            Next
        End If

        If duplicate_found Then
            check_type = "Type has to be unique"
        Else
            ' OK
        End If
    End If
End Function

' Makes sure that length is a whole number larger than -1
Function check_length(affectedRow As Long, sheet As Worksheet) As String
    Dim value As String
    value = sheet.Range(COL_LENGTH & affectedRow).value
    check_length = ""
    If value = "" Then
        check_length = "Length is missing"
    ElseIf IsNumeric(value) Then
        If Not Int(value) = value Then
            check_length = "Length cannot be decimal"
        ElseIf value < 0 Then
            check_length = "Length is below 0"
        ElseIf InStr(1, value, ".") > 0 Then
            check_length = "Length contains a dot"
        Else
            ' OK
        End If
    ElseIf Not IsNumeric(value) Then
        check_length = "Length is not a number"
    End If
End Function

' Makes sure that tolerance enabled is either 1 or 0:
Function check_tolerance_enabled(affectedRow As Long, sheet As Worksheet) As String
    Dim value As String
    value = sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value
    check_tolerance_enabled = ""
    If Not value = "0" And Not value = "1" Then
         check_tolerance_enabled = "Tolerance enabled has to be 1 or 0"
    Else
        ' OK
    End If
End Function

' Makes sure that tolerance is a whole number larger than -1
' But only checks tolerance if it is enabled in the tolerance enabled column
Function check_tolerance(affectedRow As Long, sheet As Worksheet) As String
    Dim value As String
    value = sheet.Range(COL_TOLERANCE & affectedRow).value
    check_tolerance = ""
    If value = "" Then
        If sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value = 1 Then
            check_tolerance = "Tolerance is missing"
        End If
    ElseIf IsNumeric(value) Then
        If Not Int(value) = value Then
            check_tolerance = "Tolerance cannot be decimal"
        ElseIf value < 0 Then
            check_tolerance = "Tolerance is below 0"
        ElseIf InStr(1, value, ".") > 0 Then
            check_tolerance = "Tolerance contains a dot"
        Else
            ' OK
        End If
    ElseIf Not IsNumeric(value) Then
        check_tolerance = "Tolerance is not a number"
    End If
End Function

解决支持功能

这些函数将字母转换为列，反之亦然。

Function let2Col(colStr As String) As Long
    let2Col = Range(colStr & 1).Column
End Function

Function col2Let(iCol As Long) As String
   Dim iAlpha As Long
   Dim iRemainder As Long
   iAlpha = Int(iCol / 27)
   iRemainder = iCol - (iAlpha * 26)
   If iAlpha > 0 Then
      col2Let = Chr(iAlpha + 64)
   End If
   If iRemainder > 0 Then
      col2Let = col2Let & Chr(iRemainder + 64)
   End If
End Function

代码已在 Excel 2010 及更高版本上测试/必须工作。

为清晰起见进行了编辑

【问题讨论】：

这应该移到 CodeReview
我认为您可能需要一个更“控制”的应用程序。例如，保护到工作表以禁止添加和删除列，然后编写一些代码连接到一个按钮，让用户插入一个列。那么您就不需要在该过程中进行验证了。
@dbmitch 对 Stack Overflow 来说是不是离题了？在我看来，它是在询问一个特定的问题，而不是 Stack Overflow 的题外话。
哇，好多文字。实际上，没有办法在 Excel 中正确过滤或验证用户输入。 Excel 根本不是为此而构建的。使用其他程序，或为痛苦的世界做好准备。
您考虑过使用 VBA 表单吗？我认为你想要实现的目标是可能的，但就像 vacip 所说的......“痛苦的世界”。另一种方法可能是使用表格。让用户与表单交互（表单中的数据可以显示在表单中，然后可以将任何“可接受的”更改填充回表单中）。这将使您对“字段验证”有更多的控制，包括添加或删除“列”/“行”。不相信在表格中模仿表格是个好主意，但会给你更多的控制权

标签： vba excel validation

【解决方案1】：

终于搞定了

经过一番折腾后，发现解决起来很容易。

我添加了一个新测试，通过查看范围的地址来检查用户更改的区域（目标范围）是否包含一列，如果它是一个完整的列，检查器将忽略它。这解决了验证占用 Excel 大约一分钟的问题。
相交计算的结果用于内部循环，它将检查限制在我们有兴趣验证的区域内的单元格中。

固定 Worksheet_Change 函数

Option Explicit

' Run every time something is changed in the User Input sheet
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim InterestingRange As Range
    Set InterestingRange = Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE))
    If Not InterestingRange Is Nothing Then
        ' Guard against validating every cell in an inserted column
        If Not RangeAddressRepresentsColumn(InterestingRange.address) Then
            Dim myCell As Range
            ' This loop makes it work if multiple cells are changed, 
            ' for example when pasting cells
            For Each myCell In InterestingRange.Cells
                ' Protect the header rows
                If myCell.row >= ROW_FIRST Then
                    checkInput_cell myCell.row, myCell.Column, Me
                End If
            Next
        End If
    End If
End Sub

新增支持功能

' Takes an address string as input and determines if it represents a full column
' A full column is on the form $A:$A for single or $A:$C for multiple columns
' The unique characteristic of a column address is that it has always two
' dollar signs and one colon
Public Function RangeAddressRepresentsColumn(address As String) As Integer
    Dim dollarSignCount As Integer
    Dim hasColon As Boolean
    Dim Counter As Integer
    hasColon = False
    dollarSignCount = 0
    ' Loop through each character in the string
    For Counter = 1 To Len(address)
        If Mid(address, Counter, 1) = "$" Then
            dollarSignCount = dollarSignCount + 1
        ElseIf Mid(address, Counter, 1) = ":" Then
            hasColon = True
        End If
    Next
    If hasColon And dollarSignCount = 2 Then
        RangeAddressRepresentsColumn = True
    Else
        RangeAddressRepresentsColumn = False
    End If
End Function

【讨论】：