请问怎样可以把word文档的内容批量录入到Excel中

思乡之风

Word文档格式都是固定的，请问怎样把代码改成可以输出下图的样子，万分感谢


代码如下：

1. Sub Excel操控Word()
   
2.     Dim arrData(), n As Long, mypath$, myfile$
   
3.     Dim wdapp As Object, Docx As Object, strRng As Object
   
4.     mypath = ThisWorkbook.Path & "\需要提取的doc样表4个"
   
5.     myfile = Dir(mypath & "*.docx")
   
6.     Set wdapp = CreateObject("Word.Application")
   
7.     wdapp.Visible = False
   
8.     Do While myfile <> ""
   
9.         Set Docx = wdapp.Documents.Open(mypath & myfile, Visible:=False)
   
10.         Set strRng = Docx.Content
    
11.         With CreateObject("VBScript.Regexp")
    
12.             .Global = True
    
13.             .Pattern = "宗地基本信息表[（\(]一[）\)](?:.*?\x07){8}(.+?)\r\x07(?:.*?\x07){70}(.+?)\r\x07(?:.*?\x07){46}(.+?)\r\x07"
    
14.             ReDim Preserve arrData(1 To 3, 1 To n + 1)
    
15.             For Each RegMatch In .Execute(strRng)
    
16.                 n = n + 1
    
17.                 arrData(1, n) = RegMatch.submatches(0)
    
18.                 arrData(2, n) = RegMatch.submatches(1)
    
19.                 arrData(3, n) = RegMatch.submatches(2)
    
20.             Next
    
21.         End With
    
22.         Docx.Close
    
23.         myfile = Dir
    
24.     Loop
    
25.     wdapp.Quit
    
26.     Set wdapp = Nothing
    
27.     Set Docx = Nothing
    
28.     Cells.Clear
    
29.     Range("a1:c1") = Array("使用权", "宗地代码", "宗地面积" & vbCrLf & "（㎡）")
    
30.     Range("a2").Resize(n, 3) = Application.Transpose(arrData)
    
31. End Sub

复制代码

测试.zip (35.56 KB, 下载次数: 7)

2017-10-21 08:39 上传

点击文件名下载附件