[已解决]从word中提取某些数据到excel中

1261181315a

从word中提取某些数据到excel中

最佳答案

月排行榜 / 总排行榜

dsmch

2016-1-20 21:21

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Set wd = CreateObject("Word.Application")
   
4. s = 2
   
5. With wd.Documents.Open(ThisWorkbook.Path & "\源数据.doc")
   
6.     For i = 1 To .Paragraphs.Count
   
7.         zf = .Paragraphs(i).Range
   
8.         If zf Like "*基站：*" Then
   
9.             s = s + 1
   
10.             Cells(s, 2) = Split(zf, "：")(0)
    
11.             zf2 = .Paragraphs(i + 1).Range
    
12.             Cells(s, 3) = Mid(Split(zf2, "E：")(0), 4)
    
13.             Cells(s, 4) = Replace(Split(zf2, "E：")(1), "）", "")
    
14.         End If
    
15.     Next
    
16.     .Close False
    
17. End With
    
18. End Sub

复制代码

跳转到最佳答案楼层

QCW911

可以

1261181315a

QCW911 发表于 2016-1-20 11:46
有偿编写，有意加QQ57726980

要钱的就别来了，谢谢！

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Set wd = CreateObject("Word.Application")
   
4. s = 2
   
5. With wd.Documents.Open(ThisWorkbook.Path & "\源数据.doc")
   
6.     For i = 1 To .Paragraphs.Count
   
7.         zf = .Paragraphs(i).Range
   
8.         If zf Like "*基站：*" Then
   
9.             s = s + 1
   
10.             Cells(s, 2) = Split(zf, "：")(0)
    
11.             zf2 = .Paragraphs(i + 1).Range
    
12.             Cells(s, 3) = Mid(Split(zf2, "E：")(0), 4)
    
13.             Cells(s, 4) = Replace(Split(zf2, "E：")(1), "）", "")
    
14.         End If
    
15.     Next
    
16.     .Close False
    
17. End With
    
18. End Sub

复制代码

1261181315a

dsmch 发表于 2016-1-20 21:21

数据2含有表格的文档
数据1所有表格均已删除
利用代码1（在word中操作）将word文档中的所有表格删除，最好是能把图片也删掉。再利用代码2（在excel
中操作）获取需要的信息。如此可提高程序的效率（通过对比，删除掉表格程序运行时间大大节约）。但是现在的问题是能否将代码1与代码2同时放在excel中操作，执行后即可完成任务。老师您帮忙看看。