已知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 DocumentDim xlApp As ObjectDim xlBook As ObjectDim xlSheet As ObjectDim para As ParagraphDim questionType As StringDim questionNumber As IntegerDim questionContent As StringDim options As VariantDim answer As StringDim rowIndex As Integer' 初始化Excel应用On Error Resume NextSet xlApp = GetObject(, "Excel.Application")If Err.Number <> 0 ThenSet xlApp = CreateObject("Excel.Application")End IfOn Error GoTo 0xlApp.Visible = TrueSet xlBook = xlApp.Workbooks.AddSet 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.ParagraphsDim text As Stringtext = Trim(para.Range.text)If Len(text) > 0 ThenIf Left(text, 1) = "单" Or Left(text, 1) = "多" ThenquestionType = textquestionNumber = 0questionContent = ""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 Integerindex = 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" ThenDim optionIndex As IntegeroptionIndex = 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 <> "" ThenxlSheet.Cells(rowIndex, 1).Value = questionTypexlSheet.Cells(rowIndex, 2).Value = questionNumberxlSheet.Cells(rowIndex, 3).Value = questionContentxlSheet.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 = answerrowIndex = rowIndex + 1' 重置变量以便处理下一个问题questionNumber = 0questionContent = ""ReDim options(1 To 4)options(1) = ""options(2) = ""options(3) = ""options(4) = ""answer = ""End IfEnd IfNext para' 自动调整列宽xlSheet.Columns.AutoFit' 获取当前打开的Word文档的完整路径fileName = ActiveDocument.FullName' 保存Excel文件Dim excelFileName As StringexcelFileName = Replace(fileName, ".docx", ".xlsx")xlBook.SaveAs excelFileNamexlBook.Close SaveChanges:=False' 清理对象xlApp.QuitSet xlBook = NothingSet xlSheet = NothingMsgBox "转换完成！", vbInformation
End Sub

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

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

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

5、Excel文件内容如下：

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

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

Sub BatchConvertWordToExcel()Dim wdApp As ObjectDim wdDoc As ObjectDim xlApp As ObjectDim xlBook As ObjectDim xlSheet As ObjectDim folderPath As StringDim fileName As StringDim questionType As StringDim questionNumber As IntegerDim questionContent As StringDim options As VariantDim answer As StringDim rowIndex As Integer' 初始化Excel应用On Error Resume NextSet xlApp = GetObject(, "Excel.Application")If Err.Number <> 0 ThenSet xlApp = CreateObject("Excel.Application")End IfOn Error GoTo 0xlApp.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 = FalseSet wdDoc = wdApp.Documents.Open(folderPath & "\" & fileName)' 创建新的Excel工作簿Set xlBook = xlApp.Workbooks.AddSet 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 ParagraphFor Each para In wdDoc.ParagraphsDim text As Stringtext = Trim(para.Range.text)If Len(text) > 0 ThenIf Left(text, 1) = "单" Or Left(text, 1) = "多" ThenquestionType = textquestionNumber = 0questionContent = ""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 Integerindex = 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" ThenDim optionIndex As IntegeroptionIndex = 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 <> "" ThenxlSheet.Cells(rowIndex, 1).Value = questionTypexlSheet.Cells(rowIndex, 2).Value = questionNumberxlSheet.Cells(rowIndex, 3).Value = questionContentxlSheet.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 = answerrowIndex = rowIndex + 1' 重置变量以便处理下一个问题questionNumber = 0questionContent = ""ReDim options(1 To 4)options(1) = ""options(2) = ""options(3) = ""options(4) = ""answer = ""End IfEnd IfNext para' 自动调整列宽xlSheet.Columns.AutoFit' 保存Excel文件Dim excelFileName As StringexcelFileName = Replace(fileName, ".docx", ".xlsx")xlBook.SaveAs folderPath & "\" & excelFileNamexlBook.Close SaveChanges:=False' 关闭Word文档wdDoc.Close SaveChanges:=FalsewdApp.Quit' 清理对象Set wdDoc = NothingSet wdApp = NothingSet xlBook = NothingSet xlSheet = Nothing' 获取下一个文件名fileName = DirLoop' 推出xslxlApp.QuitMsgBox "所有文档转换完成！", vbInformation
End Sub

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

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

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

总结

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