如何把word内容转为excel表格，详见附件

免费用户

工作中遇到一个题库，word格式，想转为excel格式，如附件所示样式，谢谢

免费用户

题库量比较大，好几千个题目

changhong8

都是单选？？

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim wordapp As Object
   
4.   Dim mydoc As Word.Document
   
5.   Dim i%, j%
   
6.   Dim mypath$, myname$
   
7.   Dim arr, brr(1 To 1000, 1 To 8)
   
8.   Dim reg As New RegExp
   
9.   Application.ScreenUpdating = False
   
10.   Application.DisplayAlerts = False
    
11.   ss = "A．10月17日     B．3月12日"
    
12.   With reg
    
13.     .Global = True
    
14.     .Pattern = "([A-D])．(.*?)(?=[A-D]．|$)"
    
15.     Set mh = .Execute(ss)
    
16.   End With
    
17.   mypath = ThisWorkbook.Path & ""
    
18.   myname = "题库.docx"
    
19.   If Dir(mypath & myname) = "" Then
    
20.     MsgBox mypath & myname & "不存在！"
    
21.   End If
    
22.   Set wordapp = CreateObject("word.application")
    
23.   wordapp.Visible = True
    
24.   Set mydoc = wordapp.Documents.Open(mypath & myname)
    
25.   m = 0
    
26.   With mydoc
    
27.     For i = 1 To .Paragraphs.Count
    
28.       Set aa = .Paragraphs(i)
    
29.       If aa.Range.ListFormat.ListValue > 0 Then
    
30.         m = m + 1
    
31.         brr(m, 1) = m
    
32.         brr(m, 2) = aa.Range.Text
    
33.       Else
    
34.         If reg.test(aa.Range.Text) Then
    
35.           Set mh = reg.Execute(aa.Range.Text)
    
36.           For j = 0 To mh.Count - 1
    
37.             xh = Asc(mh(j).SubMatches(0)) - 62
    
38.             nr = mh(j).SubMatches(1)
    
39.             brr(m, xh) = nr
    
40.           Next
    
41.         Else
    
42.           Select Case Left(aa.Range.Text, 2)
    
43.             Case "答案"
    
44.               brr(m, 7) = Mid(aa.Range.Text, 4)
    
45.             Case "解析"
    
46.               brr(m, 8) = Mid(aa.Range.Text, 4)
    
47.           End Select
    
48.               
    
49.         End If
    
50.       End If
    
51.     Next
    
52.   End With
    
53.   mydoc.Close False
    
54.   wordapp.Quit
    
55.   With Worksheets("sheet1")
    
56.     .UsedRange.Offset(1, 0).Clear
    
57.     With .Range("a2").Resize(m, UBound(brr, 2))
    
58.       .Value = brr
    
59.       .WrapText = True
    
60.       .Borders.LineStyle = xlContinuous
    
61.     End With
    
62.   End With
    
63. End Sub
    

复制代码

chxw68

详见附件。