Excel VBA 实现单元格支持正则是否匹配, 正则替换, 正则匹配字符串

2024年4月16日 186次阅读 来源: sarjet_lin

Excel VBA 实现单元格支持正则是否匹配, 正则替换, 正则匹配字符串

资源下载

https://download.csdn.net/download/weixin_42026002/85201545

操作方法

  1. 打开Excel
  2. 添加开发者工具, 并打开 Visual Basic
  3. 添加模块
  4. 复制以下代码
  5. Excel 另存为支持宏的(*.xlsm)格式
  6. 愉快的使用正则函数吧

函数说明

函数参数说明参数说明参数说明参数说明参数说明
Regex_IsMatchDataRange数据矩阵pattern正则表达式IsIgnoreCase是否忽略大小写
Regex_ReplaceStringDataRange数据矩阵pattern正则表达式replace替换正则IsIgnoreCase是否忽略大小写
Regex_MatchStringDataRange数据矩阵pattern正则表达式IsIgnoreCase是否忽略大小写MaxRowOrCol最大行列匹配矩阵
Regex_MatchStringGroupData数据pattern正则表达式IsIgnoreCase是否忽略大小写MatchPos匹配的项GroupPos匹配的组

例子

Regex_IsMatch

匹配多行

=Regex_IsMatch(B13:B14,“(a.+?)b”,FALSE)

匹配多列

=Regex_IsMatch($B 1 : 1: 1:C$1,“(a.+?)b”,FALSE)

匹配多行多列

=Regex_IsMatch($B 20 : 20: 20:C$21,“(a.+?)b”,FALSE)

Regex_MatchString

匹配多行

=Regex_MatchString($B 13 : 13: 13:B$14,“a.+?b”,FALSE,2)

匹配多列

=Regex_MatchString($B 1 : 1: 1:C$1,“a.+?b”,FALSE,3)

匹配多行多列

=Regex_MatchString($B 20 : 20: 20:C$21,“a.+?b”,FALSE,2)

Regex_ReplaceString

=Regex_ReplaceString($B 20 : 20: 20:C$21,“(a.+?)b”,“$1”,FALSE)

Regex_MatchStringGroup

只能匹配单元格

=Regex_MatchStringGroup(B27,“(.+)_(.+)”,FALSE,0,0)

源代码

'/**
' * @name Regex_IsMatch
' * @brief 返回正则是否匹配单元格集合
' * @version v1.0
' * @author sarjet
' * @date 22.23.15, 15:23
' * @param DataRange 单元格范围
' * @param Pattern 正则表达式
' * @param IgnoreCase 忽略大小写
' * @returns 返回对应多行多列单元格
' * @example
' **/
Public Function Regex_IsMatch(DataRange As Range, Pattern As String, Optional IgnoreCase As Boolean = True) As Variant
    Dim arRes() As Variant  '存储结果的数组
    Dim curRow As Long  '源单元格区域中当前行索引值
    Dim curCol As Long  '源单元格区域中当前列索引值
    Dim cntRows As Long  '行数
    Dim cntCols As Long  '列数
    On Error GoTo ErrHandl
    Regex_IsMatch = arRes
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = Pattern
    re.Global = True
    re.MultiLine = True
    re.IgnoreCase = IgnoreCase
    cntRows = DataRange.Rows.Count
    cntCols = DataRange.Columns.Count
    ReDim arRes(1 To cntRows, 1 To cntCols)
    For curRow = 1 To cntRows
        For curCol = 1 To cntCols
            arRes(curRow, curCol) = re.Test(DataRange.Cells(curRow, curCol).Value)
        Next
    Next
    Regex_IsMatch = arRes
    Exit Function
ErrHandl:
    Regex_IsMatch = CVErr(xlErrValue)
End Function

'/**
' * @name Regex_MatchString
' * @brief 返回正则匹配的单元格字符串集合
' * 如果字符串是一行多列, 则每列向下延伸结果;
' * 如果是多行一列, 则每行向右延伸结果;
' * 如果是多行多列, 则返回多行多列的第一个匹配的结果
' * @version v1.0
' * @author sarjet
' * @date 22.24.15, 15:24
' * @param DataRange 单元格范围
' * @param Pattern 正则表达式
' * @param IgnoreCase 忽略大小写
' * @param MaxRowOrCol 最大延伸结果, 0: 不限
' * @returns 返回自动识别计算后的多行多列单元格
' * @example
' **/
Public Function Regex_MatchString(DataRange As Range, Pattern As String, Optional IgnoreCase As Boolean = True, Optional MaxRowOrCol As Long = 0) As Variant
    Dim arRes() As String  '存储结果的数组
    Dim curRow As Long  '源单元格区域中当前行索引值
    Dim curCol As Long  '源单元格区域中当前列索引值
    Dim cntRows As Long  '行数
    Dim cntCols As Long  '列数
    Dim getv As Variant
    Dim currMatch, maxMatch As Long
    Dim rdim As Boolean
    Dim matpos As Integer
    rdim = False
    On Error GoTo ErrHandl
    Regex_MatchString = arRes
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = Pattern
    re.Global = True
    re.MultiLine = True
    re.IgnoreCase = IgnoreCase
    cntRows = DataRange.Rows.Count
    cntCols = DataRange.Columns.Count
    If (cntCols = 1) Then
        maxMatch = 0
        For curRow = 1 To cntRows
            Dim col As Long
            col = 0
            getv = DataRange.Cells(curRow, 1).Value
             'arRes(curRow, curCol) = re.Test()
            Set colMatches = re.Execute(getv)
            If (MaxRowOrCol = 0) Then
                currMatch = colMatches.Count
                If (maxMatch < currMatch) Then
                    maxMatch = currMatch
                    ReDim arRes(1 To cntRows, 1 To maxMatch)
                End If
            ElseIf (Not rdim) Then
                rdim = True
                ReDim arRes(1 To cntRows, 1 To MaxRowOrCol)
            End If
            matpos = 0
            For Each Match In colMatches
                col = col + 1
                If (col > UBound(arRes, 2)) Then
                    Exit For
                End If
                arRes(curRow, curCol + col) = Match.Value
            Next
        Next
    ElseIf (cntRows = 1) Then
        maxMatch = 0
        'ReDim arRes(1 To cntRows + MaxRowOrCol, 1 To cntCols)
        For curCol = 1 To cntCols
            Dim row As Long
            row = 0
            getv = DataRange.Cells(1, curCol).Value
             'arRes(curRow, curCol) = re.Test()
            Set colMatches = re.Execute(getv)
            currMatch = colMatches.Count
            If (MaxRowOrCol = 0) Then
                If (maxMatch < currMatch) Then
                    maxMatch = currMatch
                    ReDim arRes(1 To maxMatch, 1 To cntCols)
                End If
            ElseIf (Not rdim) Then
                rdim = True
                ReDim arRes(1 To MaxRowOrCol, 1 To cntCols)
            End If
            For Each Match In colMatches
                row = row + 1
                If (col > UBound(arRes, 1)) Then
                    Exit For
                End If
                arRes(curRow + row, curCol) = Match.Value
            Next
        Next
    Else
        ReDim arRes(1 To cntRows, 1 To cntCols)
        For curRow = 1 To cntRows
            For curCol = 1 To cntCols
                getv = DataRange.Cells(curRow, curCol).Value
                 'arRes(curRow, curCol) = re.Test()
                Set colMatches = re.Execute(getv)
                For Each Match In colMatches
                    arRes(curRow, curCol) = Match.Value
                    Exit For
                Next
            Next
        Next
    End If
SetResult:
    Regex_MatchString = arRes
    Exit Function
ErrHandl:
    Regex_MatchString = CVErr(xlErrValue)
End Function

'/**
' * @name Regex_MatchString
' * @brief 返回正则匹配的单元格字符串集合
' * 如果字符串是一行多列, 则每列向下延伸结果;
' * 如果是多行一列, 则每行向右延伸结果;
' * 如果是多行多列, 则返回多行多列的第一个匹配的结果
' * @version v1.0
' * @author sarjet
' * @date 22.24.15, 15:24
' * @param Data 单元格范围
' * @param Pattern 正则表达式
' * @param IgnoreCase 忽略大小写
' * @param MatchPos 匹配的项, 0...n 第n个匹配
' * @param GroupPos 匹配的组, 0...m 第n个匹配的第m组
' * @returns 返回自动识别计算后的多行多列单元格
' * @example
' **/
Public Function Regex_MatchStringGroup(Data As Range, Pattern As String, Optional IgnoreCase As Boolean = True, Optional MatchPos As Integer = 0, Optional GroupPos As Integer = 0) As Variant
    Dim arRes As String  '存储结果的数组
    Dim curRow As Long  '源单元格区域中当前行索引值
    Dim curCol As Long  '源单元格区域中当前列索引值
    Dim cntRows As Long  '行数
    Dim cntCols As Long  '列数
    Dim getv As Variant
    Dim currMatch, maxMatch As Long
    Dim rdim As Boolean
    Dim matpos, grppos As Integer
    Dim exitfor As Boolean
    exitfor = False
    rdim = False
    On Error GoTo ErrHandl
    Regex_MatchStringGroup = arRes
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = Pattern
    re.Global = True
    re.MultiLine = True
    re.IgnoreCase = IgnoreCase
    cntRows = Data.Rows.Count
    cntCols = Data.Columns.Count
    If (cntCols = 1 And cntRows = 1) Then
        maxMatch = 0
        For curRow = 1 To cntRows
            Dim col As Long
            col = 0
            getv = Data.Cells(curRow, 1).Value
            Set colMatches = re.Execute(getv)
            matpos = 0
            For Each Match In colMatches
                If (matpos = MatchPos) Then
                    grppos = 0
                    For Each Group In Match.SubMatches
                        If (grppos = GroupPos) Then
                            arRes = Group
                            Exit For
                        End If
                        grppos = grppos + 1
                    Next
                    Exit For
                End If
                matpos = matpos + 1
            Next
        Next
    End If
SetResult:
    Regex_MatchStringGroup = arRes
    Exit Function
ErrHandl:
    Regex_MatchStringGroup = CVErr(xlErrValue)
End Function

'/**
' * @name Regex_ReplaceString
' * @brief 返回正则替换字符串的单元格集合
' * @version v1.0
' * @author sarjet
' * @date 22.27.15, 15:27
' * @param DataRange 单元格范围
' * @param Pattern 正则表达式
' * @param Replace 替换的正则
' * @param IgnoreCase 忽略大小写
' * @returns 返回对应多行多列单元格
' * @example
' **/
Public Function Regex_ReplaceString(DataRange As Range, Pattern As String, Replace As String, Optional IgnoreCase As Boolean = True) As Variant
    Dim arRes() As Variant  '存储结果的数组
    Dim curRow As Long  '源单元格区域中当前行索引值
    Dim curCol As Long  '源单元格区域中当前列索引值
    Dim cntRows As Long  '行数
    Dim cntCols As Long  '列数
    On Error GoTo ErrHandl
    Regex_ReplaceString = arRes
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = Pattern
    re.Global = True
    re.MultiLine = True
    re.IgnoreCase = IgnoreCase
    cntRows = DataRange.Rows.Count
    cntCols = DataRange.Columns.Count
    ReDim arRes(1 To cntRows, 1 To cntCols)
    For curRow = 1 To cntRows
        For curCol = 1 To cntCols
            arRes(curRow, curCol) = re.Replace(DataRange.Cells(curRow, curCol).Value, Replace)
        Next
    Next
    Regex_ReplaceString = arRes
    Exit Function
ErrHandl:
    Regex_ReplaceString = CVErr(xlErrValue)
End Function
    原文作者：sarjet_lin
    原文地址: https://blog.csdn.net/weixin_42026002/article/details/124196288
    本文转自网络文章，转载此文章仅为分享知识，如有侵权，请联系博主进行删除。
点赞