Word中试卷各选项提取到Excel对应列

Word中试卷各选项提取到Excel对应列

 

工作中遇到问题，Word形式的试卷，其中包括选择题和简答题，需要将选择题的题干及选项分别提取到Excel对应列中，如下图：

 

图一：Word形式

 

图二：提取到Excel显示效果

从图二可以看到，提取出来的各选项列中格式不整齐，其中有带选项字母的，有没有的，这是因为Word版文件选择题中各选项字母后的小数点格式不一致，中英文都有，而VBA中是英文状态下的小数点，具体如下图：

 

图三：注意选项后小数点中英文状态

图四：最后一行中第一列仍保有选项A.

 

 

 

 

 

在此粘上Word中VBA代码：

 

以下：

 

Sub test2()

'

' test2 宏

'

'

Dim oApp As Object

  Dimoappwork, 接收表

  SetoApp = CreateObject("Excel.Application")

  Setoappwork = oApp.Workbooks.Add

  Set接收表 = oappwork.Sheets(1)

  行 = 1

  接收表.Cells(1,1) = "题目"

  接收表.Cells(1,2) = "A."

  接收表.Cells(1,3) = "B."

  接收表.Cells(1,4) = "C."

  接收表.Cells(1,5) = "D."

 

 

   For i = 1 To ActiveDocument.Paragraphs.Count

     If InStr(ActiveDocument.Paragraphs(i).Range.Text, "题目：")> 0 Then

       行 = 行 + 1

       接收表.Cells(行, 1) = ActiveDocument.Paragraphs(i).Range.Text

     ElseIf InStr(ActiveDocument.Paragraphs(i).Range.Text, "A")> 0 Then

       接收表.Cells(行, 2) = Replace(ActiveDocument.Paragraphs(i).Range.Text,"A.", "")

     ElseIf InStr(ActiveDocument.Paragraphs(i).Range.Text, "B")> 0 Then

       接收表.Cells(行, 3) = Replace(ActiveDocument.Paragraphs(i).Range.Text,"B.", "")

     ElseIf InStr(ActiveDocument.Paragraphs(i).Range.Text, "C")> 0 Then

       接收表.Cells(行, 4) = Replace(ActiveDocument.Paragraphs(i).Range.Text,"C.", "")

     ElseIf InStr(ActiveDocument.Paragraphs(i).Range.Text, "D")> 0 Then

       接收表.Cells(行, 5) = Replace(ActiveDocument.Paragraphs(i).Range.Text,"D.", "")

     End If

   Next i

 

 

 oApp.Visible = True

 

End Sub

 

 

以上

补充：

Word中VBA如何编辑

 

图五：视图/宏/编辑宏

 

图六：输入宏名/选择创建

 

图七：粘入代码后保存，同样方法选择运行宏即可自动生成新的Excel表

 

 

注意：

1、 文章开头提到Word文件里有选择题与简答题，但是提取时新建了文档只放了选择题，简答题前加上“题目：”也可以提取

2、 提取成功的前提是Word文件中选择题格式必须按照图片中来，即各个选项单独占一行，如果各选项后不是小数点而是顿号需要改成英文状态下小数点或者在VBA代码中作相应修改

希望大家相互帮助，共同进步