VBA中如何在数据验证公式中应用正则表达式匹配

我想在VBA里用正则表达式做数据验证：Excel工作表某列允许用户编辑，输入内容不符合指定格式（比如AB \d+）就弹错误提示，不让用户完成输入。

我用的正则函数在单元格里调用能正常返回TRUE/FALSE，但放到VBA数据验证的Formula1参数里就报“类型不匹配”；但通过Excel数据验证UI配置却能正常工作，我只想用VBA实现，不想碰UI。

原RegExpMatch函数接收Range参数，返回Range类型值，但数据验证公式需要字符串类型，所以我改了第二个版本，返回字符串，但只能验证单个单元格，而且整个数据验证范围的公式都基于这个单个单元格的结果。

现在有两个问题：

1. 能不能像调用EXACT函数那样，传单个单元格给RegExpMatch函数？
2. 在VBA里实现数据验证，有没有更简便的正则匹配方法？

原RegExpMatch函数 #

Public Function RegExpMatch(input_range As Range, pattern As String, Optional match_case As Boolean = True) As Variant
  Dim arRes() As Variant 'array to store the results
  Dim iInputCurRow, iInputCurCol, cntInputRows, cntInputCols As Long 'index of the current row in the source range, index of the current column in the source range, count of rows, count of columns

  On Error GoTo ErrHandl

  RegExpMatch = arRes

  Set regex = CreateObject("VBScript.RegExp")
  regex.pattern = pattern
  regex.Global = True
  regex.MultiLine = True
  If True = match_case Then
    regex.ignorecase = False
  Else
    regex.ignorecase = True
  End If

  cntInputRows = input_range.Rows.count
  cntInputCols = input_range.Columns.count
  ReDim arRes(1 To cntInputRows, 1 To cntInputCols)

  For iInputCurRow = 1 To cntInputRows
    For iInputCurCol = 1 To cntInputCols
      arRes(iInputCurRow, iInputCurCol) = regex.Test(input_range.Cells(iInputCurRow, iInputCurCol).Value)
    Next
  Next

  RegExpMatch = arRes
  Exit Function
ErrHandl:
    RegExpMatch = CVErr(xlErrValue)
End Function

数据验证函数 #

For Col = 1 To Cells(1, Columns.count).End(xlToLeft).Column
       
    If Cells(1, Col).Value = "Fruit" Then
        With Range(Cells(2, Col), Cells(1048576, Col)).Validation
        .Delete
     
        l1 = Split((Columns(Col - 1).Address(, 0)), ":")(0) & "2"
        Dim s1 As String
        s1 = Split((Columns(Col).Address(, 0)), ":")(0) & "2"
        
       
        regex_results = RegExpMatch(Range(Cells(2, Col), Cells(1048576, Col)), "Fruit \d+")
        fr_formula = "=AND(EXACT(" & l1 & ", ""New Fruit""), " & regex_results & ")"
        .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Formula1:=fr_formula
        'CHANGE 1 END
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Error"
        .InputMessage = "Editable if 'Fruit = New Fruit'. Please Enter in this format: Fruit 12345"
        .ErrorMessage = "Please Enter in valid format: Fruit 12345 only for New Fruit"
        .ShowInput = True
        .ShowError = True
        End With
    End If
Next Col

方案二：修改后的RegExpMatch函数及验证代码 #

修改后的RegExpMatch函数 #

Public Function RegExpMatch(input_range As String, pattern As String) As Boolean
    Set regex = CreateObject("VBScript.RegExp")
    regex.pattern = pattern
    regex.ignorecase = False
    regex_matches = regex.Test(Range(input_range).Value)

    res = "True"
    If regex_matches = False Then
        res = "False"
    End If
  RegExpMatch = res
  Exit Function
ErrHandl:
    RegExpMatch = CVErr(xlErrValue)
End Function

对应的数据验证代码片段 #

s1 = Split((Columns(Col).Address(, 0)), ":")(0) & "2"
fr_formula = "=AND(EXACT(" & l1 & ", ""NewFR""), EXACT(""" & RegExpMatch(s1, "FR \d+") & """, ""True""))"

问题解答 #

1. 可以像调用EXACT那样传单个单元格给RegExpMatch

原函数的问题在于返回的是二维数组，而数据验证的Formula1需要的是字符串公式，公式里要直接调用函数并引用当前单元格。修改函数使其同时支持单个单元格和区域输入，返回布尔值即可：

Public Function RegExpMatch(input_val As Variant, pattern As String, Optional match_case As Boolean = True) As Variant
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.pattern = pattern
    regex.Global = True
    regex.MultiLine = True
    regex.IgnoreCase = Not match_case
    
    ' 处理单个单元格/值的情况
    If TypeName(input_val) = "Range" Then
        If input_val.Cells.Count = 1 Then
            RegExpMatch = regex.Test(input_val.Value)
        Else
            ' 处理区域的情况，返回数组
            Dim resArr() As Boolean
            ReDim resArr(1 To input_val.Rows.Count, 1 To input_val.Columns.Count)
            Dim r As Long, c As Long
            For r = 1 To input_val.Rows.Count
                For c = 1 To input_val.Columns.Count
                    resArr(r, c) = regex.Test(input_val.Cells(r, c).Value)
                Next c
            Next r
            RegExpMatch = resArr
        End If
    Else
        ' 直接传入值的情况
        RegExpMatch = regex.Test(input_val)
    End If
End Function

此时数据验证公式可写成：

fr_formula = "=AND(EXACT(" & l1 & ", ""New Fruit""), RegExpMatch(" & s1 & ", ""Fruit \d+""))"

注意s1要用相对引用（比如Cells(2, Col).Address(False, False)），这样整列每个单元格都会验证自身内容。

2. VBA实现正则数据验证的简便方法

核心是让自定义函数能被数据验证公式正确调用，避免在VBA中提前计算函数结果，而是让Excel在验证时自动计算。简化后的完整代码：

Sub AddRegexValidation()
    Dim col As Long
    Dim targetCol As Range
    Dim formulaStr As String
    Dim prevColAddr As String
    Dim currColAddr As String
    
    For col = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        If Cells(1, col).Value = "Fruit" Then
            Set targetCol = Range(Cells(2, col), Cells(Rows.Count, col).End(xlUp))
            With targetCol.Validation
                .Delete
                ' 获取相对引用地址
                prevColAddr = Cells(2, col - 1).Address(False, False)
                currColAddr = Cells(2, col).Address(False, False)
                ' 构建验证公式
                formulaStr = "=AND(EXACT(" & prevColAddr & ", ""New Fruit""), RegExpMatch(" & currColAddr & ", ""Fruit \d+""))"
                .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Formula1:=formulaStr
                .IgnoreBlank = True
                .InputMessage = "仅当左侧为'New Fruit'时可编辑，请输入格式：Fruit 12345"
                .ErrorMessage = "格式错误！请输入：Fruit 12345（仅在左侧为New Fruit时允许编辑）"
                .ShowInput = True
                .ShowError = True
            End With
        End If
    Next col
End Sub

该方案优势：

• 自定义函数同时支持单个单元格和区域调用
• 数据验证用相对引用，整列单元格各自验证自身内容
• 完全通过VBA实现，无需操作UI

内容的提问来源于stack exchange，提问作者please_help_with_questions