求可查找高亮Word文件指定词句的VBA宏 用于作业批改查重

优化后VBA代码 #

Sub ComparePhraseList()
    Dim sCheckDoc As String
    Dim docRef As Document
    Dim docCurrent As Document
    Dim i As Integer
    Dim oPara As Range
    Dim matchCount As Long

    ' 参考抄袭短语库路径，自行修改为实际路径即可
    sCheckDoc = "C:\Users\dekle\OneDrive\Desktop\UNISA 2021\Plagiarism\Plagiarism Assignment 3 master.docx"
    Set docCurrent = Selection.Document
    Set docRef = Documents.Open(sCheckDoc, Visible:=False) ' 后台打开参考文档，无多余弹窗
    docCurrent.Activate
    Options.DefaultHighlightColorIndex = wdRed ' 可自行修改为wdYellow等其他高亮颜色

    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .Replacement.Text = "^&"
        .Forward = True
        .Format = True
        ' 核心匹配规则调整
        .MatchCase = False ' 忽略大小写差异
        .MatchWholeWord = False ' 不强制要求整词完全匹配
        .MatchWildcards = False
        .MatchSoundsLike = True ' 适配少量拼写错误的场景
        .MatchAllWordForms = True ' 适配词性、时态变化的洗稿场景（比如do/doing/done可关联匹配）
        .IgnorePunct = True ' 忽略标点符号差异
        .IgnoreSpace = True ' 忽略多余空格、换行的格式差异
        .Wrap = wdFindContinue
    End With

    matchCount = 0
    For i = 1 To docRef.Paragraphs.Count
        Set oPara = docRef.Paragraphs(i).Range
        oPara.End = oPara.End - 1
        ' 跳过参考文档内的空白段落，避免无效匹配
        If Len(Trim(oPara.Text)) = 0 Then GoTo NextPara
        
        Selection.Find.Text = oPara.Text
        If Selection.Find.Execute(Replace:=wdReplaceAll) Then
            matchCount = matchCount + 1
        End If
NextPara:
    Next i

    docRef.Close SaveChanges:=wdDoNotSaveChanges
    docCurrent.Activate
    ' 释放内存资源
    Set docRef = Nothing
    Set docCurrent = Nothing
    Set oPara = Nothing
    MsgBox "匹配完成，共命中" & matchCount & "条抄袭短语", vbInformation
End Sub

调整说明 #

• 原代码匹配规则过于严格，新增的忽略大小写、标点、空格配置，可适配学生提交内容的常见格式改动
• 新增的近似拼写、词形变化匹配规则，可识别学生少量拼写错误、修改词性时态的洗稿行为
• 运行过程后台加载参考短语库，无多余窗口干扰，自动跳过参考库内空行避免无效匹配
• 运行结束后弹出命中统计提示，可直观看到匹配结果

内容的提问来源于stack exchange，提问作者Braam de Klerk