[已解决]从word文档提取数据至excel表

xxaadd66

从多个word文档里提取word文档页眉上的数据和应该怎么写代码？（详见附件指令单）（红色文字部分是需要提取的数据）
       比如：excel表格里需要的数据是页眉上的“编号：xxxxxx”+责任人：“xxxx”+事由：“xxxxxxxxx”也是一行一个文档数据，代码该怎么写？
      谢谢了[em44]

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-26 11:08

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Set wd = CreateObject("Word.Application")
   
4. wj = Dir(mypath & "*.doc"): n = 1
   
5. Do While wj <> ""
   
6.     n = n + 1: Cells(n, 1) = n - 1
   
7.     With wd.Documents.Open(mypath & wj)
   
8.         x = Split(.Range.Text, vbCr)
   
9.         Cells(n, 2) = Mid(.Sections(1).Headers(1).Range.Text, 4)
   
10.         For i = 0 To UBound(x)
    
11.             If x(i) Like "主送部门责任人：*" Then
    
12.                 y = Split(x(i), "抄送")(0)
    
13.                 Cells(n, 4) = Mid(y, 10)
    
14.             End If
    
15.             If x(i) Like "事由：*" Then
    
16.                 Cells(n, 3) = Mid(x(i), 4)
    
17.                 Exit For
    
18.             End If
    
19.         Next
    
20.         .Close False
    
21.     End With
    
22.     wj = Dir
    
23. Loop
    
24. wd.Quit
    
25. End Sub

复制代码

跳转到最佳答案楼层

xxaadd66

自己顶啊，[em07]

xxaadd66

没人来看么？来高手看看呀，来大神帮帮忙啊~

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Set wd = CreateObject("Word.Application")
   
4. wj = Dir(mypath & "*.doc"): n = 1
   
5. Do While wj <> ""
   
6.     n = n + 1: Cells(n, 1) = n - 1
   
7.     With wd.Documents.Open(mypath & wj)
   
8.         x = Split(.Range.Text, vbCr)
   
9.         Cells(n, 2) = Mid(.Sections(1).Headers(1).Range.Text, 4)
   
10.         For i = 0 To UBound(x)
    
11.             If x(i) Like "主送部门责任人：*" Then
    
12.                 y = Split(x(i), "抄送")(0)
    
13.                 Cells(n, 4) = Mid(y, 10)
    
14.             End If
    
15.             If x(i) Like "事由：*" Then
    
16.                 Cells(n, 3) = Mid(x(i), 4)
    
17.                 Exit For
    
18.             End If
    
19.         Next
    
20.         .Close False
    
21.     End With
    
22.     wj = Dir
    
23. Loop
    
24. wd.Quit
    
25. End Sub

复制代码

xxaadd66

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

谢谢dsmch老师的回答，感谢感谢[em31]