Question

怎么实现用vba 批量的搜索文档内容并收集到一张excel表里面

如题，有大量的文档里面都包含这些信息
3、井斜情况：
直井段：0-1242.00（井斜角0～5.81º）
增斜段：1242.00-1396.00m（井斜角5.8～24.81º）
稳斜段：1396.00-2253.00m（井斜角24.81～24.00º）
调整段：2253.00-2301.00m（井斜角24.00～19.19º）
稳斜段：2301.00-2655.00m（井斜角19.19～19.80º）
造斜点井深：1242.00m
最大井斜：27.01/1632.47
还有其他文字、图、表。
但是我现在只想知道带有“增斜段”“造斜段”“造斜点”这三个字样后面的数据，word文件很多，几百个，可以整理到一个文件夹里没问题。目标excel希望存储这些信息的方式是，列A为文档名，列B-D分别为带有“增斜段”“造斜段”“造斜点”这些字样的改行数据。请问有没有哪位编程大神能教教我

Answer 1

 Sub 提取数据()
   Dim Word As Object, WordDoc As Object
   Dim Path As String, Fname As String, Again As Boolean
   Dim Row As Long, Pos As Double, Pos2 As Double
   Dim Data1 As String, Data2 As String, Data3 As String
   Row = 2
   Path = ActiveWorkbook.Path
   On Error Resume Next
   Set Word = GetObject(, "Word.Application")
   If Err.Number Or Word Is Nothing Then Set Word = CreateObject("Word.Application")
   Word.DisplayAlerts = 0
   Word.Visible = 0
   Fname = Dir(Path & "\*.doc")
   If Fname = "" Then Fname = Dir(Path & "\*.docx")
Above2007:
   If Fname <> "" Then
    Do
     Data1 = ""
     Data2 = ""
     Data3 = ""
     Set WordDoc = Word.documents.Open(Path & "\" & Fname)
     Word.Selection.WholeStory
     Pos = InStr(Word.Selection, "增斜段")
     Pos2 = InStr(Pos + 4, Word.Selection, vbCr)
     If Pos Then Data1 = Mid(Word.Selection, Pos + 5, Pos2 - Pos - 5)
     Pos = InStr(Word.Selection, "造斜段")
     Pos2 = InStr(Pos + 4, Word.Selection, vbCr)
     If Pos Then Data2 = Mid(Word.Selection, Pos + 5, Pos2 - Pos - 5)
      Pos = InStr(Word.Selection, "造斜点")
      Pos2 = InStr(Pos + 4, Word.Selection, vbCr)
      If Pos Then Data3 = Mid(Word.Selection, Pos + 5, Pos2 - Pos - 5)
      Pos = InStrRev(Fname, ".")
      Fname = Left(Fname, Pos - 1)
      On Error Resume Next
      ActiveSheet.Cells(Row, 1).Value = Fname
      If Err.Number Then ActiveSheet.Cells(Row, 1) = Fname
      On Error Resume Next
      ActiveSheet.Cells(Row, 2).Value = Data1
      If Err.Number Then ActiveSheet.Cells(Row, 2) = Data1
      On Error Resume Next
      ActiveSheet.Cells(Row, 3).Value = Data2
      If Err.Number Then ActiveSheet.Cells(Row, 3) = Data2
      On Error Resume Next
      ActiveSheet.Cells(Row, 4).Value = Data3
      If Err.Number Then ActiveSheet.Cells(Row, 4) = Data3
      WordDoc.Saved = True
      WordDoc.Close
      Row = Row + 1
      Fname = Dir()
      Loop While Fname <> ""
      Fname = Dir(Path & "\*.docx")
      If Fname <> "" And Not Again Then
       Again = True
       GoTo Above2007
      End If
     Word.DisplayAlerts = -1
     Word.Quit
     Set Word = Nothing
     Set WordDoc = Nothing
     ActiveWorkbook.Save
     MsgBox "提取完毕！" & vbCrLf & "更多功能，请参见文件批量处理百宝箱V10.0", vbInformation + vbOKOnly, "消息"
   End If
   
End Sub

将该VBA宏代码原样复制粘贴到Excel的宏代码中，然后保存该excel文档，将所有待处理的word文档集中在一个文件夹中，并将这个Excel文件也保存在这个文件夹中，然后打开这个excel文件，打开宏代码，按F5键运行即可。

Answer 2

vba读取word内容会弄吗？
dir(*.Doc)知道怎么用吗？
大约思路吧
1、枚举所有word文档
2、查找word中的你需要的内容
3、填写到excel表中
呵呵，不知道你vba水平如何，但按你的题目，我也只能回答这么多了。按这个思路百度去，总会找到办法的。

追问

我现在已经实现批量转换word文档转换成txt了。我看excel好像直接有导入txt的功能。我的txt导入excel以后变成了每一行文字占第一列的一个单元格。目前的问题是，我需要的文本为“　　造斜点井深：1242.00m”这一行，但是我需要实现两个问题，第一个就是能不能把导入的这个文件名跟这一行数据放在一行对齐？第二个就是怎么提取里面的数字？用不用vba都没关系了。

追答

造斜点井深：1242.00m 是否肯定都在某个格式？比如A5单元格。如果是，直接判断提取

if instr(cells(i,1),"造斜点井深")>0 then ....处理
“　　造斜点井深：1242.00m”提取1242.00的办法

x=“　　造斜点井深：1242.00m”

y=val(split(x,"：")(1))