在Word文档中，用VBA快速生成学生错题

zhangdabai1

已于 2023-08-18 10:48:13 修改

阅读量322

点赞数 1

分类专栏： wordVBA 文章标签： word

于 2023-08-04 17:20:03 首次发布

本文链接：https://blog.csdn.net/zhangdabai1/article/details/132108514

版权

wordVBA 专栏收录该内容

4 篇文章 0 订阅

订阅专栏

为了方便在Word文档中，给学生整理错题，所以用VBA实现了生成错题文档的快捷方法。代码中涉及查找光标的读取和定位，自动识别替换答案解析，自动识别题干并删除，字体和标题的设置等内容

1、使用方法

选中对应的题目和答案解析，运行代码添加当前错题；然后继续选中其他错题，再次点击添加，则会添加第二道错题，以此类推：

2、生成的错题文档

3、代码

Option Explicit
Public cuotiCount As Integer '记录错题数量
Sub 添加当前错题()
    Dim 当前文档 As Document
    Set 当前文档 = ActiveDocument
    
    If Selection.Range.End - Selection.Range.Start <= 0 Then
        MsgBox ("请选中要添加的错题，再重新操作")
        Exit Sub
    Else
        Selection.Copy
    End If
    Call 当前错题文档检测
    Dim targetDocument As Document
    Set targetDocument = Documents.Open("H:\用户\桌面\错题文件\当前错题.docx")  ' 替换成你的实际路径
    
    ' 将复制的内容粘贴到"当前错题"文档中
    Selection.EndKey Unit:=wdStory, Extend:=wdMove '到文档末端
    cuotiCount = cuotiCount + 1
    Call 输入错题编号(cuotiCount)
    Selection.PasteAndFormat Type:=wdUseDestinationStylesRecovery ' 粘贴
    Selection.MoveUp Unit:=wdLine, count:=1, Extend:=wdMove '向上一位
    Selection.EndKey Unit:=wdLine, Extend:=wdMove '到最右端
    With Selection.Font
        .Size = 10 '五号字体大小为10
        .name = "Times New Roman" '罗马字体
        .Color = RGB(255, 255, 255) '颜色为白色
    End With
    Selection.TypeText Text:="      -end-" '输入文字

    ' 保存并关闭文档
    targetDocument.Save
    targetDocument.Close
    当前文档.Activate
End Sub

Sub 生成学生版()
    Dim targetDocument1 As Document
    Dim zb As Long
    Set targetDocument1 = Documents.Open("H:\用户\桌面\错题文件\当前错题.docx")  ' 替换成你的实际路径
    
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Selection.MoveDown Unit:=wdLine, count:=1, Extend:=wdMove
    Selection.HomeKey Unit:=wdLine, Extend:=wdMove
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Selection.Copy
    Selection.HomeKey Unit:=wdStory, Extend:=wdMove
    Call 全部替换("【答案】*-end-", "", 1)
    Selection.EndKey Unit:=wdStory, Extend:=wdMove '到文档末端
    Selection.InsertBreak Type:=wdPageBreak '下一页
    If Selection.Information(wdActiveEndPageNumber) Mod 2 <> 1 Then
        Selection.InsertBreak Type:=wdPageBreak '下一页
    End If
    Selection.Style = "标题 3"
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '在文档居中
    With Selection.Font
        .Size = 16 '三号字体大小为16
        .name = "黑体"
        .name = "Times New Roman" '罗马字体
        .ColorIndex = wdBlack
    End With
    Selection.TypeText Text:=year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日" & "错题-答案解析" '输入文字
    Selection.TypeParagraph '回车
    zb = Selection.Range.End
    Selection.PasteAndFormat Type:=wdUseDestinationStylesRecovery
    Call 识别解析中题干并删除(zb)
    Call 另存文档
    Kill ("H:\用户\桌面\错题文件\当前错题.docx")
End Sub

Sub 检测错题文件夹()
    Dim folderPath As String
    Dim folderName As String
    ' 指定文件夹路径和名称
    folderPath = "H:\用户\桌面\"
    folderName = "错题文件"
    ' 检测指定路径中是否存在该文件夹
    If Dir(folderPath & folderName, vbDirectory) = "" Then
        ' 不存在文件夹，创建文件夹
        MkDir folderPath & folderName
'        MsgBox "成功创建文件夹：" & folderName, vbInformation
    Else
        ' 存在文件夹
        '        MsgBox "文件夹已存在：" & folderName, vbInformation
    End If
End Sub

Sub 当前错题文档检测()
    Dim filePath As String
    filePath = "H:\用户\桌面\错题文件\当前错题.docx" ' 替换成你的实际路径
    Call 检测错题文件夹
    ' 检测文档是否存在
    If Dir(filePath) = "" Then
        ' 如果文档不存在，则新建一个文档并命名为"当前错题"
        Documents.Add.SaveAs filePath
        Call 输入文档标题
        Call 插入页码
        cuotiCount = 0
    End If
End Sub

Sub 输入文档标题()
    Selection.Style = "标题 3"
    With Selection.Font
        .Size = 16 '三号字体大小为16
        .name = "黑体"
        .name = "Times New Roman" '罗马字体
        .ColorIndex = wdBlack
    End With
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '在文档居中
    Selection.TypeText Text:=year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日" & "错题" '输入文字
    Selection.TypeParagraph
    Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft '左对齐
End Sub

Function 输入错题编号(a As Integer)
    ' 宏由 ZPL 录制，时间: 2023/08/01
    Selection.Style = "标题 5"
    With Selection.Font
        .name = "华文隶书"
        .Size = 14
        .SizeBi = 14
        .Bold = -1
        .BoldBi = -1
        .ColorIndex = wdRed
    End With
    Selection.TypeText Text:="错题 " & a
    Selection.TypeParagraph
    '    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend'向前选中一行
End Function

Sub 另存文档()
    Dim name, shijian, allname As String
    name = InputBox("请输入学生名字：")
    shijian = Format(Now, "yyyy-mm-dd hh-mm-ss")
    allname = "H:\用户\桌面\错题文件\" & name & "错题" & shijian & ".docx"
    RecentFiles.Add Document:=allname, ReadOnly:=False
    ActiveDocument.SaveAs FileName:=allname, FileFormat:=12, LockComments:=False, AddToRecentFiles:=True, ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False, Encoding:=0, InsertLineBreaks:=False, AllowSubstitutions:=False, LineEnding:=0, AddBiDiMarks:=False
    ActiveDocument.Save
    ActiveDocument.Close
    MsgBox (name & " 本次的 " & cuotiCount & " 道错题已生成到错题文件中！")
End Sub

Function 识别解析中题干并删除(坐标 As Long)
    Dim k1, k2, j1, j2 As Long
    Dim b As Integer
    b = cuotiCount - 1
    Selection.SetRange Start:=坐标, End:=坐标 '重选选中
    Call 是否重复(0)
    While b >= 0
        Call 查找("错题*【答案】", 1, 1)
        If 是否重复(1) = 1 Then
            Exit Function
        End If
        k1 = Selection.Range.Start
        k2 = Selection.Range.End
        '重新选中
        Selection.MoveLeft Unit:=wdCharacter, count:=1, Extend:=wdMove
        Selection.MoveDown Unit:=wdLine, count:=1, Extend:=wdMove
        j1 = Selection.Range.Start
        Selection.SetRange Start:=k2, End:=k2
        Selection.HomeKey Unit:=wdLine, Extend:=wdMove
        Selection.MoveLeft Unit:=wdCharacter, count:=1, Extend:=wdMove
        j2 = Selection.Range.Start
        Selection.SetRange Start:=j1, End:=j2 '重选选中
        Selection.Delete
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend '向右选中行
        Selection.Delete
        b = b - 1
    Wend
End Function

4、其他调用到的子程序

Function 全部替换(原文字, 替换为, 通配符)

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = 原文字
        .Forward = True
        .Wrap = wdFindStop 'Wrap = wdFindAsk(找到会弹出提示框)'Wrap = wdFindStop(完成替换会停止)
        .MatchCase = False 'True 指定要查找的文本应区分大小写。
        .MatchByte = False   '搜索期间区分全角和半角字母或字符，则此属性返回 True ;否则返回 False 。 将属性值设置为 True 或 False 以启用或禁用该功能。
        .MatchWildcards = 通配符 '通配符开关
        .MatchWholeWord = False '真 要查找只整个单词，全字匹配。
        .MatchFuzzy = False '确定 Microsoft Word 在搜索过程中是否对日语文本使用非特定搜索选项
        .Replacement.Text = 替换为
    End With
    With Selection.Find
        .Style = ""
        .Highlight = wdUndefined
        With .Replacement
            .Style = ""
            .Highlight = wdUndefined
        End With
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Replacement.Text = 替换为
    
        Selection.Find.Font.Reset
    Selection.Find.ParagraphFormat.Reset

End Function

Public Function 是否重复(初始化 As Boolean)
        '初始化
        If 初始化 = 0 Then
            新坐标 = 0
            原坐标 = 0
        End If
        
        '逻辑判断
        新坐标 = Selection.Range.End
        If 新坐标 <= 原坐标 Then
            是否重复 = 1
            Exit Function
        Else
            是否重复 = 0
            原坐标 = 新坐标
        End If

End Function