VBA正则匹配需求：提取关键词及所在整行/段落

核心思路 #

• 优先匹配长关键词，避免短关键词截断多词短语（比如先匹配feel differently而非different）
• 正则模式精准定位段落边界：以说话人标识xxx：作为段落起始，下一个说话人标识或文本结尾作为段落结束
• 利用正则分组捕获，同时拿到完整段落和匹配的关键词

实现步骤与代码 #

1. 提取并处理关键词

• 从关键词工作表单列提取数据，按关键词长度降序排序
• 拼接成正则匹配分支，同时处理正则特殊字符（通用场景必备）

' 提取关键词（假设关键词在Sheet1的A列，从A2开始）
Dim keywords As Collection
Set keywords = New Collection
On Error Resume Next
Dim cell As Range
For Each cell In Sheet1.Range("A2:A" & Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row)
    If Trim(cell.Value) <> "" Then
        keywords.Add Trim(cell.Value)
    End If
Next
On Error GoTo 0

' 按关键词长度降序排序（避免短关键词优先匹配）
Dim temp As String
For i = 1 To keywords.Count - 1
    For j = i + 1 To keywords.Count
        If Len(keywords(i)) < Len(keywords(j)) Then
            temp = keywords(i)
            keywords(i) = keywords(j)
            keywords(j) = temp
        End If
    Next j
Next i

' 拼接成正则分支（转义可能的特殊字符）
Dim keywordPattern As String
keywordPattern = ""
For i = 1 To keywords.Count
    keywordPattern = keywordPattern & "|" & EscapeRegEx(keywords(i))
Next i
keywordPattern = Mid(keywordPattern, 2) ' 去掉开头的|

2. 构建正则表达式

• 开启全局匹配与多行模式，忽略大小写（可按需调整）
• 模式同时捕获段落内容和目标关键词

' 正则转义函数（处理正则特殊字符）
Function EscapeRegEx(str As String) As String
    Dim specialChars As Variant
    specialChars = Array("\", "^", "$", ".", "|", "?", "*", "+", "(", ")", "[", "]", "{", "}")
    Dim char As Variant
    For Each char In specialChars
        str = Replace(str, char, "\" & char)
    Next
    EscapeRegEx = str
End Function

' 构建正则模式
Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")
With regEx
    .Global = True
    .MultiLine = True
    .IgnoreCase = True ' 忽略大小写，根据需求调整
    ' 模式说明：
    ' (?<=^|\n) ：匹配段落起始（行首或换行后）
    ' ([a-z]+：.*?) ：捕获段落开头的说话人标识及关键词前内容
    ' (' & keywordPattern & ') ：捕获匹配的目标关键词
    ' (.*?) ：捕获关键词后的段落剩余内容
    ' (?=\n[a-z]+：|$) ：匹配段落结束（下一个说话人标识或文本结尾）
    .Pattern = "(?<=^|\n)([a-z]+：.*?)(" & keywordPattern & ")(.*?)(?=\n[a-z]+：|$)"
End With

3. 一次性匹配提取结果

• 直接对拼接后的逐字稿文本执行全局匹配
• 遍历匹配结果，分别提取完整段落和对应关键词

' 假设逐字稿拼接文本存放在变量transcriptText中
Dim matches As Object
Set matches = regEx.Execute(transcriptText)

' 遍历匹配结果
Dim match As Object
For Each match In matches
    Dim fullParagraph As String
    Dim matchedKeyword As String
    fullParagraph = match.SubMatches(0) & match.SubMatches(1) & match.SubMatches(2)
    matchedKeyword = match.SubMatches(1)
    ' 此处可将结果写入工作表或进行其他处理
    Debug.Print "完整段落：" & fullParagraph
    Debug.Print "匹配关键词：" & matchedKeyword
    Debug.Print "------------------------"
Next

示例验证结果 #

针对你提供的示例文本和关键词，运行后会精准捕获：

• 包含affect的tody第一段，关键词为affect
• 包含eager的tody第一段，关键词为eager
• 包含feel differently的anabelle段落，关键词为feel differently
• 包含long-lasting的tody第二段，关键词为long-lasting
• 包含different的simran段落，关键词为different
• 包含lasting effect的simran段落，关键词为lasting effect

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