[已解决][求助]关于从word文档提取数据到excel表格的问题

xxaadd66

别的部门发来的各种指令单，都是doc格式的，我想用宏或者代码直接提取数据批量导入一个excel表格中，请各位高手帮帮忙~~
      比如：名称：xxxx     时间：xxxxxxxx     地点：xxxx
                 净值：xxxx    原值：xxxxxxxxx   
               这样的word文档数据，提取到excel表格里按列排列到一起，如下：
               名称   时间   地点   净值   原值
               xxx    xxx    xxx    xxx    xxx
    代码应该怎么写呢？大神，高手帮帮忙呀~~谢谢了

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-24 22:34

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, k%
   
3. mypath = ThisWorkbook.Path & "\指令单合集"
   
4. arr = [a1:j1]
   
5. ReDim brr(1 To 2000, 1 To UBound(arr, 2))
   
6. Dim wd As New Word.Application
   
7. wj = Dir(mypath & "*.doc")
   
8. Do While wj <> ""
   
9.     With wd.Documents.Open(mypath & wj)
   
10.         x = Split(.Range.Text, vbCr)
    
11.         n = n + 1
    
12.         For i = 0 To UBound(x)
    
13.             s = 0
    
14.             For j = 1 To UBound(arr, 2) - 3 Step 3
    
15.                 s = s + 1
    
16.                 If x(i) Like "*" & arr(1, j) & "*" Then
    
17.                     For k = j To j + 3
    
18.                         x(i) = Replace(x(i), arr(1, k) & "：", ",")
    
19.                     Next
    
20.                     y = Split(Replace(x(i), " ", ""), ",")
    
21.                     For k = 1 To UBound(y)
    
22.                         brr(n, j + k - 1) = y(k)
    
23.                     Next
    
24.                     Exit For
    
25.                 End If
    
26.                     
    
27.             Next
    
28.         Next
    
29.         .Close False
    
30.     End With
    
31.     wj = Dir
    
32. Loop
    
33. wd.Quit
    
34. Range("a2").Resize(n, 10) = brr
    
35. End Sub

复制代码

跳转到最佳答案楼层

xxaadd66

没人回复么，顶顶更健康，大神快来吧~

xxaadd66

{:021:}

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, i&, j%, k%
   
3. mypath = ThisWorkbook.Path & "\指令单合集"
   
4. arr = [a1:j1]
   
5. ReDim brr(1 To 2000, 1 To UBound(arr, 2))
   
6. Dim wd As New Word.Application
   
7. wj = Dir(mypath & "*.doc")
   
8. Do While wj <> ""
   
9.     With wd.Documents.Open(mypath & wj)
   
10.         x = Split(.Range.Text, vbCr)
    
11.         n = n + 1
    
12.         For i = 0 To UBound(x)
    
13.             s = 0
    
14.             For j = 1 To UBound(arr, 2) - 3 Step 3
    
15.                 s = s + 1
    
16.                 If x(i) Like "*" & arr(1, j) & "*" Then
    
17.                     For k = j To j + 3
    
18.                         x(i) = Replace(x(i), arr(1, k) & "：", ",")
    
19.                     Next
    
20.                     y = Split(Replace(x(i), " ", ""), ",")
    
21.                     For k = 1 To UBound(y)
    
22.                         brr(n, j + k - 1) = y(k)
    
23.                     Next
    
24.                     Exit For
    
25.                 End If
    
26.                     
    
27.             Next
    
28.         Next
    
29.         .Close False
    
30.     End With
    
31.     wj = Dir
    
32. Loop
    
33. wd.Quit
    
34. Range("a2").Resize(n, 10) = brr
    
35. End Sub

复制代码

xxaadd66

dsmch 发表于 2016-5-24 22:34

感谢dsmch大神的回答，另外，麻烦问下，如果要提取word文档页眉上的数据应该怎么做？（详见附件指令单）
       比如：excel表格里需要的数据是页眉上的“编号：xxxxxx”+责任人：“xxxx”+事由：“xxxxxxxxx”也是一行一个文档数据，代码该怎么写？
      谢谢了[em44]

xxaadd66

dsmch 发表于 2016-5-24 22:34

可以请dsmch老师解释一下您写的那段代码么，我用“VBA程序解释器_网友wzqoo修改版”这个没看懂[em07]

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Set wd = CreateObject("Word.Application")
   
4. wj = Dir(mypath & "*.doc")
   
5. Do While wj <> ""
   
6.     With wd.Documents.Open(mypath & wj)
   
7.         MsgBox .Sections(1).Headers(1).Range.Text
   
8.         .Close False
   
9.     End With
   
10.     wj = Dir
    
11. Loop
    
12. wd.Quit
    
13. End Sub

复制代码

xxaadd66

dsmch 发表于 2016-5-26 08:09

dsmch老师，我复制您的代码运行后是这样的？是哪一步错了吗？我新建了一个宏，将代码复制进去然后运行就这样了[em09]

xxaadd66

xxaadd66 发表于 2016-5-26 08:33
dsmch老师，我复制您的代码运行后是这样的？是哪一步错了吗？我新建了一个宏，将代码复制进去然后运行就这 ...

对不起，是我没描述清楚，我的意思不是提取之后以对话框的形式显示，还是要导入到excel表格里的，原谅我还不会写代码，麻烦老师还将代码写完整，提取页眉内容+责任人+事由的形式导入excel表格，万分感谢，若有叨扰，还请见谅。[em44][em44]

xxaadd66

xxaadd66 发表于 2016-5-26 11:15
对不起，是我没描述清楚，我的意思不是提取之后以对话框的形式显示，还是要导入到excel表格里的，原谅我还 ...

谢谢dsmch老师，我发了两个帖子，您都回答了，感谢感谢，万分感谢[em44]