如何编写Word VBA宏自动标记文章三分之一单词生成完形填空？

API 探路者

2026-8-8

问题描述

作为Word VBA初学者，此前需手动给目标单词添加前缀=，再运行已有的Convert宏将文章转换为完形填空格式。现希望编写新宏，自动为选中范围的三分之一单词随机添加前缀=，再通过现有宏完成转换，但不知如何实现该标记宏。

附已有Convert宏代码：

Sub Convert()
Application.ScreenUpdating = False

    Selection.HomeKey Unit:=wdStory        'init
    
    Dim iCount, A, i      As Long
    Dim RPT, CHAR, WordRpt, Eventual As Integer
    iCount = 0
    WordRpt = 1
    Eventual = 0
    
    Selection.Find.ClearFormatting        'A and I
    Selection.Find.Replacement.ClearFormatting
    
    Selection.HomeKey Unit:=wdStory
    With ActiveDocument.Content.Find        'sum A
        .Text = "=a "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        Do While .Execute
            A = A + 1
        Loop
    End With
    
    Selection.HomeKey Unit:=wdStory
    With ActiveDocument.Content.Find        'sum I
        .Text = "=i "
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        Do While .Execute
            i = i + 1
        Loop
    End With
    
    With Selection.Find
        .Text = "=a "
        .Replacement.Text = "_ "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "=i "
        .Replacement.Text = "_ "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With ActiveDocument.Content.Find        'sum equals
        .Text = "="
        .Format = False
        .Wrap = wdFindStop
        Do While .Execute
            iCount = iCount + 1
        Loop
    End With
    While WordRpt <= iCount
        WordRpt = WordRpt + 1
        With Selection.Find        'next equal
            .ClearFormatting
            .MatchWholeWord = True
            .MatchCase = False
            .Execute FindText:="="
            
            Selection.TypeBackspace
            Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
            CHAR = Len(Selection) - 2
            Selection.MoveLeft Unit:=wdCharacter, Count:=1
            Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            Selection.Cut
            Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
            Selection.PasteAndFormat (wdFormatOriginalFormatting)
            UdsRpt = 1        'underscore
            Do While UdsRpt <= CHAR
                UdsRpt = UdsRpt + 1
                Selection.TypeText Text:="_"
            Loop
            Selection.TypeText Text:" "
        End With
    Wend
    
    '
    ' patch comma
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ ,"
        .Replacement.Text = "__,"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch period
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ ."
        .Replacement.Text = "__."
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch question mark
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ ?"
        .Replacement.Text = "__?"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch exclamation mark
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ !"
        .Replacement.Text = "__!"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch slash
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ /"
        .Replacement.Text = "__/"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch back slash
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ \\"
        .Replacement.Text = "__\\"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch colon
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ :"
        .Replacement.Text = "__:"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch semi colon
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ ;"
        .Replacement.Text = "__;"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch dash
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ –"
        .Replacement.Text = "__–"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch hyphen
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ -"
        .Replacement.Text = "__-"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    '
    ' patch ellipsis
    '
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "_ …"
        .Replacement.Text = "__…"
        .Forward = True
        .ClearFormatting
        .MatchWholeWord = True
        .MatchCase = False
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Eventual = A + i + iCount
    MsgBox "Successfully converted " & Eventual & " words.", vbOKOnly, "Task Completed"
    Application.ScreenUpdating = True

End Sub

（注：原代码中部分标点替换多了冗余逗号，已修正）

解决方案：自动标记单词的宏实现

核心逻辑

校验是否有选中文本，无则提示用户
提取选中区域内的所有单词，统计总数
计算需标记的单词量（总单词数的1/3，向下取整）
通过洗牌算法随机筛选目标单词，添加=前缀
自动调用现有Convert宏完成完形填空转换

实现代码

Sub MarkRandomWordsForCloze()
    Application.ScreenUpdating = False
    Dim selRange As Range
    Dim allWords As Variant
    Dim wordCount As Integer
    Dim markCount As Integer
    Dim i As Integer, j As Integer
    Dim randomIndex As Integer
    Dim temp As Variant
    
    ' 检查选中状态
    If Selection.Type <> wdSelectionNormal Then
        MsgBox "请先选中要处理的文本范围！", vbExclamation, "提示"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    Set selRange = Selection.Range
    
    ' 拆分选中文本为单词数组
    allWords = Split(selRange.Text, " ")
    wordCount = UBound(allWords) + 1
    
    ' 计算标记数量
    markCount = Int(wordCount / 3)
    If markCount = 0 Then
        MsgBox "选中的文本太短，无法生成足够空题！", vbExclamation, "提示"
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' Fisher-Yates洗牌算法打乱单词顺序
    Randomize
    For i = wordCount - 1 To 1 Step -1
        randomIndex = Int(Rnd * (i + 1))
        temp = allWords(i)
        allWords(i) = allWords(randomIndex)
        allWords(randomIndex) = temp
    Next i
    
    ' 给前N个随机单词添加=前缀
    For i = 0 To markCount - 1
        If Trim(allWords(i)) <> "" Then
            allWords(i) = "=" & allWords(i)
        End If
    Next i
    
    ' 替换选中区域的文本
    selRange.Text = Join(allWords, " ")
    
    ' 调用转换宏
    Convert
    
    Application.ScreenUpdating = True
    MsgBox "已完成标记并转换为完形填空格式！", vbInformation, "完成"
End Sub

使用步骤

打开Word VBA编辑器（快捷键Alt+F11）
在现有模块中粘贴上述MarkRandomWordsForCloze代码
返回Word界面，选中需要处理的文本
运行宏（可通过「开发工具-宏」选择运行，或添加到快速访问工具栏）

注意事项

宏会自动跳过空字符串，避免标记无效内容
洗牌算法保证每个单词被选中的概率均等
若选中文本单词数不足3个，会触发提示无法生成空题

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

如何编写Word VBA宏自动标记文章三分之一单词生成完形填空？

核心逻辑 #

实现代码 #

使用步骤 #

注意事项 #

核心逻辑

实现代码

使用步骤

注意事项