Excel宏标记在所有工作表中标记关键字(以域名为例)并将结果输出到另一张Sheet

Excel宏标记在所有工作表中标记关键字(以域名为例)并将结果输出到另一张Sheet

因为我的需求是标记一组url，所以使用正则进行匹配，将匹配到的url标红，并将标记结果统计输出到新建的名为“标记结果”的Sheet中

效果如下：

统计页

代码如下

Sub MatchAllWorksheetsAndHighlightURLs()
    Dim rng As Range
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim ws As Worksheet
    Dim resultSheet As String, title As String
    Dim i As Integer, j As Integer, count As Integer
    Dim url As String
    resultSheet = "标记结果"
    i = 1
    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
            
    ' 设置正则表达式模式
    regex.Global = True
    regex.Pattern = "(https?://)?(www\.|baijiahao\.|zh\.|en\.)?(baidu|zhihu|xueqiu|jianshu|docin|m\.doc88|mp\.sohu|new\.qq|dy\.163|wikipedia)/?(\.(com|org))?"
    
    If Not WorksheetExists(resultSheet) Then
        Dim size
        size = Sheets.count
        Sheets.Add After:=Sheets(size)
        Worksheets(size + 1).Name = resultSheet
    End If
    
   ' 遍历每个工作簿中的所有工作表
        For Each ws In ThisWorkbook.Worksheets
            ws.Activate ' 激活当前工作表
            title = ActiveSheet.Name
            j = 2
            count = 0
            ' 在每个工作表上执行匹配和标红逻辑
            For Each rng In ws.UsedRange
                ' 使用正则表达式进行匹配
                Set matches = regex.Execute(rng.Value)
                count = count + matches.count
                If matches.count > 0 Then
                    If title <> resultSheet Then
                       Sheets(resultSheet).Activate
                       Cells(1, i).Value = title
                       Cells(j, i).Value = rng.Value
                       ws.Activate
                       j = j + 1
                    End If
                End If
                ' 遍历每个匹配项
                Dim offset As Integer
                offset = 0
                
                For Each match In matches
                    ' 提取匹配到的URL
                    
                    url = match.Value
                    ' 标记匹配成功的URL部分为红色
                    Dim startPos As Integer
                    startPos = InStr(offset + 1, rng.Value, url, vbTextCompare)
                    
                    If startPos > 0 Then
                        Dim endPos As Integer
                        endPos = startPos + Len(url) - 1
                        
                        rng.Characters(Start:=startPos, Length:=Len(url)).Font.Color = RGB(255, 0, 0)
                        
                        ' 更新偏移量，以匹配下一个URL
                        offset = endPos
                    End If
                    
                    ' 输出匹配到的URL
                    Debug.Print url
                Next match
            Next rng
            If count > 0 Then
                i = i + 1
            End If
        Next ws
    MsgBox "域名标记完成，标记结果已输出到<标记结果>工作表"
End Sub

Function WorksheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    WorksheetExists = Not ws Is Nothing
End Function

高级功能

如果想实现：只编写一次宏，就能够在本地任意的excel中运行，甚至像下放图片所示直接在工具栏一键执行，可留言，要是留言多就出教程，没人看就算了