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

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

资源下载

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

操作方法

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

函数说明

函数	参数	说明	参数	说明	参数	说明	参数	说明	参数	说明
Regex_IsMatch	DataRange	数据矩阵	pattern	正则表达式	IsIgnoreCase	是否忽略大小写
Regex_ReplaceString	DataRange	数据矩阵	pattern	正则表达式	replace	替换正则	IsIgnoreCase	是否忽略大小写
Regex_MatchString	DataRange	数据矩阵	pattern	正则表达式	IsIgnoreCase	是否忽略大小写	MaxRowOrCol	最大行列匹配矩阵
Regex_MatchStringGroup	Data	数据	pattern	正则表达式	IsIgnoreCase	是否忽略大小写	MatchPos	匹配的项	GroupPos	匹配的组

例子

Regex_IsMatch

匹配多行

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

匹配多列

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

匹配多行多列

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

Regex_MatchString

匹配多行

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

匹配多列

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

匹配多行多列

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

Regex_ReplaceString

=Regex_ReplaceString($B$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