vba循环跳过_Excel题库转Word版本（学习VBA在Excel和Word数据交互处理中的应用）

最新推荐文章于 2024-08-20 17:04:37 发布

weixin_39804631

最新推荐文章于 2024-08-20 17:04:37 发布

阅读量506

点赞数

请关注微信公众号：金融数学 FinancialMathematics

【因本人有实际工作需要整理的代码，这里贴一个简单的框架用作笔记，同时提供给有需求的朋友。】
通过“Excel试题库转Word版本”这样一个应用实例，学习VBA在Excel和Word数据交互处理中的应用。本代码是运行在Excel环境中，实现对Word的操作，与直接在Word中写VBA代码还是有些许区别的。

一、实例背景

实例：Excel试题库转Word版本

素材：Excel版本的试题库，各章节的试题分别保存在不同的工作簿中，每章节包含单选题、多选题和判断题三类题型（即每个工作薄中分别包含以上三类习题）。素材结果如下图所示：

目标：将各章节试题汇总，按照题型分类，分别保存到Word文档中，基本格式如下：

1.题干
A.选项
B.选项
C.选项
D.选项
试题难度：难
试题答案：ABC

要求对Word进行基本的排版，包含对试题进行编号、字体及字号设置等。

二、VBA实现说明

手工操作需要重复大量的复制粘贴操作，人工耗费大且效率低下。VBA不仅能用于处理Excel数据，同样可以处理Word内容，进行排版等操作。因此，借助VBA工具作为桥梁，实现Excel与Word数据交互处理，提高工作效率。

下面，通过代码分解说明具体实现过程。

1.创建Word Application对象引用并新建空白文档

VBA对于Excel的处理比较简单，之前也有介绍，这里不作过多说明。主要介绍如何处理Word对象，第一个问题就是建立一个对Word Application对象的引用。

    '创建word应用对象
    Dim WordApp As Object
    Set WordApp = CreateObject("Word.Application")

    '创建word文档对象，并新建文档
    Dim SinDoc As Object
    Set SinDoc = WordApp.documents.Add

2.向Word文档中插入文字内容

以上代码实现了Word Application对象的应用，并创建了一个新的空白文档。接下来，就要往该文档中插入内容。

    Dim SinC As Object
    Set SinC = SinDoc.Content

    '插入内容
    SinC.InsertAfter "测试内容" & vbCrLf
    SinC.InsertParagraphAfter

通过ActiveDocument.Content.InsertAfter的方式在文档末尾插入内容，其中vbCrLf表示插入一个换行符（相当于回车）；通过ActiveDocument.Content.InsertParagraphAfter的方式在文档末尾添加一个空段落（相当于两次回车）。

3.段落格式调整

以上基本简单介绍了如何新建Word Application对象的引用，新建空白文档及文字内容插入等方法，接下来要做的事情就是格式调整，这里仅介绍简单的格式调整，包括字体、字号、段落对齐方式及段落首行缩进。

Sub SetFont(ChosedDoc, FontName, FontSize, Optional Alig = 0, Optional Inde = 2)

    With ChosedDoc.Paragraphs(ChosedDoc.Paragraphs.Count).Range
        .Font.Name = FontName '字体
        .Font.Size = FontSize '字号
        .ParagraphFormat.Alignment = Alig '对齐方式
        .ParagraphFormat.CharacterUnitFirstLineIndent = Inde '首行缩进
    End With

End Sub

为了排版美观，对题干及选项等文字内容设置不同的格式，所以对段落格式调整比较频繁，几乎每次插入都需要设置该段落的格式，因此将段落格式调整单独写进了一个函数，并且包含两个默认参数。对齐方式：0表示左对齐，1表示居中对齐，2表示右对齐。首行缩进，直接指定缩进量，一般为2，即两个空格。

以上就是本实例中所有涉及到的对Word对象的操作，剩余的就是针对问题场景的解决方案流程设计，没有太多新鲜的东西。

三、VBA排版结果

1.VBA排版前后文件

如图3是运行前素材，我们将各章节Excel试题库放在文件夹“Excel试题”下，工作簿“Excel试题转word工具代码 - v1.0.et”中包含所需的VBA代码。运行该段代码后，得到如图4的结果，相比运行前，多了三个Word文档，分别保存单选题、多选题和判断题。

2.排版效果及前后对比

首先，我们先看一下排版前试题库内容及格式，如图5-8：

排版后的效果：

排版结果目前还比较简单，主要是没有在代码中深加工，完全可以根据自己的需求进行深加工。

四、附代码

运行该段代码前，请务必将正在编辑的Word文档保存，以免内容丢失。或者注释掉WordApp.Quit。

Option Explicit

'======================================
'作者：刘**；
'日期：2019-04-22；
'功能：Excel题库转Word版本；
'======================================

Public Sub ExcelToWord()

    '创建word应用对象
    Dim WordApp As Object
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True

    '创建word文档对象，并新建文档
    Dim SinDoc As Object, MulDoc As Object, JudDoc As Object
    Set SinDoc = WordApp.documents.Add
    Set MulDoc = WordApp.documents.Add
    Set JudDoc = WordApp.documents.Add

    Dim SinC As Object, MulC As Object, JudC As Object
    Set SinC = SinDoc.Content
    Set MulC = MulDoc.Content
    Set JudC = JudDoc.Content

    '插入标题，设置格式
    Call SetFont(SinDoc, "黑体", 18, 1)
    SinC.InsertAfter "单选题" & vbCrLf
    SinC.InsertParagraphAfter

    Call SetFont(MulDoc, "黑体", 18, 1)
    MulC.InsertAfter "多选题" & vbCrLf
    MulC.InsertParagraphAfter

    Call SetFont(JudDoc, "黑体", 18, 1)
    JudC.InsertAfter "判断题" & vbCrLf
    JudC.InsertParagraphAfter

    'Excel试题文件对象
    Dim QuenWb As Workbook, QuenSht As Worksheet
    Dim FileName As String
    FileName = Dir(ThisWorkbook.Path & "/" & "Excel试题" & "/" & "*.et")

    '统计各类试题题目数（用以添加题号）
    Dim SinNum As Integer, MulNum As Integer, JudNum As Integer
    SinNum = 1
    MulNum = 1
    JudNum = 1

    '一些循环变量
    Dim TotalRows As Integer, i As Integer, j As Integer, loc As Byte

    '声明试题类型、试题内容、答案等对象
    Dim QuenType As String, QuenStr As String, Answer As String

    '循环处理Excel试题文件（支持多文件试题汇总处理）
    Do While FileName <> ""

        'Excel试题文件
        Workbooks.Open ThisWorkbook.Path & "/" & "Excel试题" & "/" & FileName, ReadOnly:=True
        Set QuenWb = ActiveWorkbook
        Set QuenSht = QuenWb.Sheets(1)
        TotalRows = QuenSht.UsedRange.Rows.Count 'Excel文件已使用行数

        '循环处理行
        For i = 1 To TotalRows

            '获取并判断试题类型
            QuenType = QuenSht.Range("A" & i).Value
            On Error Resume Next
            loc = 0 '初始化，避免保留上次残留值
            loc = WorksheetFunction.Match(QuenType, Array("判断题", "单选题", "多选题"), 0)
            On Error GoTo 0

            '非试题标记，跳过不处理
            If loc = 0 Then
                GoTo nexti
            End If

            '处理答案内容，将数字标记替换为字母（或对错）
            Answer = QuenSht.Range("D" & i).Value
            If QuenType <> "判断题" Then
                Answer = Replace(Answer, "1", "A")
                Answer = Replace(Answer, "2", "B")
                Answer = Replace(Answer, "3", "C")
                Answer = Replace(Answer, "4", "D")
            Else
                Answer = Replace(Answer, "1", "√")
                Answer = Replace(Answer, "2", "×")
            End If

            '根据不同试题类型，依次处理
            If QuenType = "单选题" Then
                '设置字体格式（试题标题格式）
                Call SetFont(SinDoc, "黑体", 12)
                '插入试题标题
                QuenStr = SinNum & "." & QuenSht.Range("C" & i).Value & vbCrLf
                SinC.InsertAfter QuenStr
                '设置字体格式（标题之外内容）
                Call SetFont(SinDoc, "楷体", 12)
                '插入试题选项、难易程度、答案等内容
                QuenStr = "A." & QuenSht.Range("E" & i).Value & vbCrLf & "B." & QuenSht.Range("F" & i).Value & vbCrLf & "C." & QuenSht.Range("G" & i).Value & vbCrLf & "D." & QuenSht.Range("H" & i).Value & vbCrLf _
                          & "难易程度:" & QuenSht.Range("B" & i).Value & vbCrLf _
                          & "试题答案：" & Answer & vbCrLf
                SinC.InsertAfter QuenStr
                SinC.InsertParagraphAfter '插入空白段落
                '该类型题目数量加1
                SinNum = SinNum + 1

            ElseIf QuenType = "多选题" Then

                Call SetFont(MulDoc, "黑体", 12)
                QuenStr = MulNum & "." & QuenSht.Range("C" & i).Value & vbCrLf
                MulC.InsertAfter QuenStr

                Call SetFont(MulDoc, "楷体", 12)
                QuenStr = "A." & QuenSht.Range("E" & i).Value & vbCrLf & "B." & QuenSht.Range("F" & i).Value & vbCrLf & "C." & QuenSht.Range("G" & i).Value & vbCrLf & "D." & QuenSht.Range("H" & i).Value & vbCrLf _
                          & "难易程度:" & QuenSht.Range("B" & i).Value & vbCrLf _
                          & "试题答案：" & Answer & vbCrLf
                MulC.InsertAfter QuenStr
                MulC.InsertParagraphAfter

                MulNum = MulNum + 1

            ElseIf QuenType = "判断题" Then

                Call SetFont(JudDoc, "黑体", 12)
                QuenStr = JudNum & "." & QuenSht.Range("C" & i).Value & "（ ）" & vbCrLf
                JudC.InsertAfter QuenStr

                Call SetFont(JudDoc, "楷体", 12)
                QuenStr = "难易程度:" & QuenSht.Range("B" & i).Value & vbCrLf _
                          & "试题答案：" & Answer & vbCrLf
                JudC.InsertAfter QuenStr
                JudC.InsertParagraphAfter

                JudNum = JudNum + 1

            Else
                MsgBox "出错！请检查题目类型" & "“" & QuenType & "”" & "是否为预期内容！" '正常情况下此句不会执行
            End If

nexti:            Next i

        '关闭Excel试题文件
        QuenWb.Close

        '下一个Excel试题文件
        FileName = Dir

    Loop

    '保存并关闭word文档
    SinDoc.SaveAs ThisWorkbook.Path & "/" & "单选题.wps"
    MulDoc.SaveAs ThisWorkbook.Path & "/" & "多选题.wps"
    JudDoc.SaveAs ThisWorkbook.Path & "/" & "判断题.wps"
    SinDoc.Close
    MulDoc.Close
    JudDoc.Close

    '退出word应用
    WordApp.Quit

End Sub


'设置段落格式
Sub SetFont(ChosedDoc, FontName, FontSize, Optional Alig = 0, Optional Inde = 2)

    With ChosedDoc.Paragraphs(ChosedDoc.Paragraphs.Count).Range
        .Font.Name = FontName '字体
        .Font.Size = FontSize '字号
        .ParagraphFormat.Alignment = Alig '对齐方式
        .ParagraphFormat.CharacterUnitFirstLineIndent = Inde '首行缩进
    End With

End Sub