Word内容格式固定下的自动化转换：Word转Excel宏实现详解

文章目录

需求描述

现在有多个Word文档，Word文档格式固定，假如Word内容分为单选题和多选题，每个题目分为：序号、中文或英文"．"、题目描述、中文"（"、答案选项、中文"）"。
举例：
单选题
1．和测试与工具包括（A）
A．啊v哦v我v
B．武侠脚本挂机啊v化工厂
C．3
D．4

2．特色无重码九年创刊不是就他擦还吃不吃开始v查卡布v吧在v额v为日本v我不必（B）
A．擦额hi v
B．参加纪念册看没看
C．3
D．4

多选题
1．读学多爱吃南昌看看选（ACD）
A．1
B．2
C．按实际产能我可没
D．4

2．测试多选啊沉默啊是擦弄完呢偶然恩菲日文（ABCD）
A．1
B．2
C．按此呢女剑客
D．4

现在需要将Word文档转为Excel，每个Excel表头包括：题目类型、题目编号、题目描述、A选项描述、B选项描述、C选项描述、D选项描述、答案
例如：

一、宏是什么？

在Word中，宏是一个批量处理程序命令，可以在Word自带的Visual Basic for Applications (VBA)编辑器中，通过各种代码实现对Word文档批量处理的功能。

二、使用步骤

1.启用开发工具

2、“更多” –> “选项”

3、“自定义功能区” –> “自定义功能区”，勾选"开发工具"。

4、打开VB

5、打开"工程资源管理器"

6、在"模块" –> “插入” –> “模块”

7、右侧可填入VBA代码

2.VBA基础知识

基本操作：
1、在VBA中，可以使用下划线符号_作为换行符号的一种方式。 当一行代码过长时，可以在需要换行的地方添加下划线符号，然后在下一行继续编写代码。
2、注释：
1.1 以单引号 ' 开头的，但如果这个符号是在双引号之内的，则视为文本，不做为注释引导符，这个符号后面的内容均为注释内容。
1.2 REM后加注释内容（REM与注释内容要空开），REM可以写在其他语句内，但关键词REM后要加冒号“：”。
3、If 条件一 And 条件二 And 条件三 Then 执行if成功的逻辑
ElseIf 条件一 And 条件二 And 条件三 Then 执行ElseIf成功的逻辑
ElseIf ‘表示If结束
4、支持使用（）进行多条件复合判断，例如If A And (C Or D)。当条件A为true，且条件C 或条件D有一为true时，If为真
5、一切未制定类型的变量都是Variant，可以放入任何数据，包括数组、对象等等，使用ReDim options(1 To 4)函数重构为数组4
6、大于>、小于<、等于=、不等于<>
7、Dim text As String 定义字符串变量text

函数方法：
1、Trim() 是去除字符串头或尾部的空格，但不包含中间的空格。
2、Len(text) 获取text（String）的长度。
3、Left(text, 1) 获取text左数，第一个字符。
4、Mid(text, 1, 1) 获取text字符串，从第1个位置起，取一个字符。
5、Mid(text, 1) 获取text字符串，从第1个位置起，取剩余字符。
6、CInt("1") 将字符串转为整型数v据。
7、InStrRev(text, "（") 从右往左获取text里，左括号“（“的位置，假如text=“擦办法把加粗卡机才能看。”，“。”，可得。的位置为1
8、InStr(text, "（") 从左往右获取text里，左括号“（“的位置。
9、InStr(start, text, "（", mode) 从左往右获取text里"（"的位置，start开始位置（可省略）,mode匹配模式，1文本模式，0二进制模式，文本模式忽略大小写（可省略）。

3.单个Word文件转为Excel

实现将单个Word文档转为Excel文件：
1、VBA代码：

Sub ConvertWordToExcel()
    Dim wdDoc As Document
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim para As Paragraph
    Dim questionType As String
    Dim questionNumber As Integer
    Dim questionContent As String
    Dim options As Variant
    Dim answer As String
    Dim rowIndex As Integer
    
    ' 初始化Excel应用
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    
    ' 写入表头
    xlSheet.Cells(1, 1).Value = "题目类型"
    xlSheet.Cells(1, 2).Value = "题目编号"
    xlSheet.Cells(1, 3).Value = "题目内容"
    xlSheet.Cells(1, 4).Value = "选项A"
    xlSheet.Cells(1, 5).Value = "选项B"
    xlSheet.Cells(1, 6).Value = "选项C"
    xlSheet.Cells(1, 7).Value = "选项D"
    xlSheet.Cells(1, 8).Value = "答案"
    
    rowIndex = 2
    
    ' 初始化选项数组
    ReDim options(1 To 4)
    options(1) = ""
    options(2) = ""
    options(3) = ""
    options(4) = ""
    
    ' 遍历每个段落
    For Each para In ActiveDocument.Paragraphs
        Dim text As String
        text = Trim(para.Range.text)
        
        If Len(text) > 0 Then
            If Left(text, 1) = "单" Or Left(text, 1) = "多" Then
                questionType = text
                questionNumber = 0
                questionContent = ""
                ReDim options(1 To 4)
                options(1) = ""
                options(2) = ""
                options(3) = ""
                options(4) = ""
                answer = ""
            ElseIf IsNumeric(Left(text, 1)) And (InStr(2, text, "．") > 1 Or InStr(2, text, ".") > 1) Then
                ' 提取题目编号和题目内容
                Dim index As Integer
                index = InStr(2, text, "．") + InStr(2, text, ".")
                questionNumber = CInt(Left(text, index - 1))
                questionContent = Trim(Mid(text, index + 1, InStrRev(text, "（") - index - 1))
                answer = Mid(text, InStrRev(text, "（") + 1, InStrRev(text, "）") - InStrRev(text, "（") - 1)
            ElseIf Left(text, 1) = "A" Or Left(text, 1) = "B" Or Left(text, 1) = "C" Or Left(text, 1) = "D" Then
                Dim optionIndex As Integer
                optionIndex = Asc(Mid(text, 1, 1)) - 64 ' A -> 1, B -> 2, etc.
                options(optionIndex) = Mid(text, 3)
            End If
            
            ' 检查是否已经收集完一个问题的所有信息
            If questionType <> "" And questionNumber > 0 And questionContent <> "" And _
               (Len(options(1)) > 0 And Len(options(2)) > 0 And Len(options(3)) > 0 And Len(options(4)) > 0) And _
               answer <> "" Then
                
                xlSheet.Cells(rowIndex, 1).Value = questionType
                xlSheet.Cells(rowIndex, 2).Value = questionNumber
                xlSheet.Cells(rowIndex, 3).Value = questionContent
                xlSheet.Cells(rowIndex, 4).Value = options(1)
                xlSheet.Cells(rowIndex, 5).Value = options(2)
                xlSheet.Cells(rowIndex, 6).Value = options(3)
                xlSheet.Cells(rowIndex, 7).Value = options(4)
                xlSheet.Cells(rowIndex, 8).Value = answer
                
                rowIndex = rowIndex + 1
                
                ' 重置变量以便处理下一个问题
                questionNumber = 0
                questionContent = ""
                ReDim options(1 To 4)
                options(1) = ""
                options(2) = ""
                options(3) = ""
                options(4) = ""
                answer = ""
            End If
        End If
    Next para
    
    ' 自动调整列宽
    xlSheet.Columns.AutoFit
    
    ' 获取当前打开的Word文档的完整路径
    fileName = ActiveDocument.FullName
    
    ' 保存Excel文件
    Dim excelFileName As String
    excelFileName = Replace(fileName, ".docx", ".xlsx")
    xlBook.SaveAs excelFileName
    xlBook.Close SaveChanges:=False
    
    ' 清理对象
    xlApp.Quit
    Set xlBook = Nothing
    Set xlSheet = Nothing
    
    MsgBox "转换完成！", vbInformation
End Sub

2、将以上代码复制粘贴到区域，并保存。

3、“开发工具” –> “宏” –> 选择宏名 –> “运行”。

4、已生成Word同名的Excel文件。

5、Excel文件内容如下：

4.批量将Word文件转为Excel文件

实现批量将Word文档转为Excel文件

Sub BatchConvertWordToExcel()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim folderPath As String
    Dim fileName As String
    Dim questionType As String
    Dim questionNumber As Integer
    Dim questionContent As String
    Dim options As Variant
    Dim answer As String
    Dim rowIndex As Integer
    
    ' 初始化Excel应用
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    xlApp.Visible = True
    
    ' 设置文件夹路径
    folderPath = InputBox("请输入包含Word文档的文件夹路径:")
    
    If folderPath = "" Then Exit Sub
    
    ' 遍历文件夹中的所有Word文档
    fileName = Dir(folderPath & "\*.docx")
    
    Do While fileName <> ""
        ' 打开Word文档
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = False
        
        Set wdDoc = wdApp.Documents.Open(folderPath & "\" & fileName)
        
        ' 创建新的Excel工作簿
        Set xlBook = xlApp.Workbooks.Add
        Set xlSheet = xlBook.Sheets(1)
        
        ' 写入表头
        xlSheet.Cells(1, 1).Value = "题目类型"
        xlSheet.Cells(1, 2).Value = "题目编号"
        xlSheet.Cells(1, 3).Value = "题目内容"
        xlSheet.Cells(1, 4).Value = "选项A"
        xlSheet.Cells(1, 5).Value = "选项B"
        xlSheet.Cells(1, 6).Value = "选项C"
        xlSheet.Cells(1, 7).Value = "选项D"
        xlSheet.Cells(1, 8).Value = "答案"
        
        rowIndex = 2
        
        ' 初始化选项数组
        ReDim options(1 To 4)
        options(1) = ""
        options(2) = ""
        options(3) = ""
        options(4) = ""
        
        ' 遍历每个段落
        Dim para As Paragraph
        For Each para In wdDoc.Paragraphs
            Dim text As String
            text = Trim(para.Range.text)
            
            If Len(text) > 0 Then
                If Left(text, 1) = "单" Or Left(text, 1) = "多" Then
                    questionType = text
                    questionNumber = 0
                    questionContent = ""
                    ReDim options(1 To 4)
                    options(1) = ""
                    options(2) = ""
                    options(3) = ""
                    options(4) = ""
                    answer = ""
                ElseIf IsNumeric(Left(text, 1)) And (InStr(2, text, "．") > 1 Or InStr(2, text, ".") > 1) Then
                    ' 提取题目编号和题目内容
                    Dim index As Integer
                    index = InStr(2, text, "．") + InStr(2, text, ".")
                    questionNumber = CInt(Left(text, index - 1))
                    questionContent = Trim(Mid(text, index + 1, InStrRev(text, "（") - index - 1))
                    questionNumber = CInt(Left(text, 1))
                    questionContent = Trim(Mid(text, 3, InStrRev(text, "（") - 3))
                    answer = Mid(text, InStrRev(text, "（") + 1, InStrRev(text, "）") - InStrRev(text, "（") - 1)
                ElseIf Left(text, 1) = "A" Or Left(text, 1) = "B" Or Left(text, 1) = "C" Or Left(text, 1) = "D" Then
                    Dim optionIndex As Integer
                    optionIndex = Asc(Mid(text, 1, 1)) - 64 ' A -> 1, B -> 2, etc.
                    options(optionIndex) = Mid(text, 3)
                End If
                
                ' 检查是否已经收集完一个问题的所有信息
                If questionType <> "" And questionNumber > 0 And questionContent <> "" And _
                   (Len(options(1)) > 0 And Len(options(2)) > 0 And Len(options(3)) > 0 And Len(options(4)) > 0) And _
                   answer <> "" Then
                    
                    xlSheet.Cells(rowIndex, 1).Value = questionType
                    xlSheet.Cells(rowIndex, 2).Value = questionNumber
                    xlSheet.Cells(rowIndex, 3).Value = questionContent
                    xlSheet.Cells(rowIndex, 4).Value = options(1)
                    xlSheet.Cells(rowIndex, 5).Value = options(2)
                    xlSheet.Cells(rowIndex, 6).Value = options(3)
                    xlSheet.Cells(rowIndex, 7).Value = options(4)
                    xlSheet.Cells(rowIndex, 8).Value = answer
                    
                    rowIndex = rowIndex + 1
                    
                    ' 重置变量以便处理下一个问题
                    questionNumber = 0
                    questionContent = ""
                    ReDim options(1 To 4)
                    options(1) = ""
                    options(2) = ""
                    options(3) = ""
                    options(4) = ""
                    answer = ""
                End If
            End If
        Next para
        
        ' 自动调整列宽
        xlSheet.Columns.AutoFit
        
        ' 保存Excel文件
        Dim excelFileName As String
        excelFileName = Replace(fileName, ".docx", ".xlsx")
        xlBook.SaveAs folderPath & "\" & excelFileName
        xlBook.Close SaveChanges:=False
        
        ' 关闭Word文档
        wdDoc.Close SaveChanges:=False
        wdApp.Quit
        
        ' 清理对象
        Set wdDoc = Nothing
        Set wdApp = Nothing
        Set xlBook = Nothing
        Set xlSheet = Nothing
        
        ' 获取下一个文件名
        fileName = Dir
    Loop
    
    ' 推出xsl
    xlApp.Quit
    
    MsgBox "所有文档转换完成！", vbInformation
End Sub

2、将以上代码复制粘贴到区域，并保存。

3、“开发工具” –> “宏” –> 选择宏名 –> “运行”。
需要当前文档不在批量处理的路径下
假如需要批量处理“C:\ChangeWord”文件夹下的word文档，需要打开另一个路径下的word（否则会出现循环打开文件，出现异常），触发宏，在弹出的框里输入路径。

4、已生成Word同名的Excel文件。

总结

通过上述方法，支持将单个Word转为Excel，也支持批量处理Word文档，转为Excel，可根据具体情况，采用不同的方式。

作者：开心，你呢