利用Excel的VBA提取word中的数据，部分非表格

kuangben8

关于遍历文件夹获取数据汇总的求助帖
http://club.excelhome.net/thread-1368474-1-1.html
(出处: ExcelHome技术论坛)

mxscgwh

不错不错呀学习了

乐乐2006201505

Sub test()  'http://club.excelhome.net/thread-1352166-1-1.html
    For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
            Process.Terminate (0)
    Next
  Dim wordapp As Object
  Dim mydoc As Object
  Dim mytab As Object
  Set wordapp = CreateObject("word.application")
  Set mydoc = CreateObject("word.document")
  Dim r%, i%
  Dim myapth$, myname$
    Dim reg As Object
    Set reg = CreateObject("vbscript.regexp")
  Dim brr(1 To 10000, 1 To 6)
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  mypath = ThisWorkbook.Path & "\"
  myname = Dir(mypath & "*.doc")
  m = 0
  Do While myname <> ""
    Set mydoc = wordapp.Documents.Open(mypath & myname)
    With mydoc
    sr = .Paragraphs(3).Range.Text
      With .Tables(1)
        m = m + 1
        brr(m, 1) = m
        brr(m, 2) = Replace(.Cell(3, 2).Range.Text, Chr$(13) & Chr$(7), "")
        brr(m, 3) = Replace(.Cell(3, 6).Range.Text, Chr$(13) & Chr$(7), "")
        brr(m, 4) = Replace(.Cell(6, 2).Range.Text, Chr$(13) & Chr$(7), "")
        
    With reg
        .Global = True
        .IgnoreCase = True
        .Pattern = "([0-9]+\.?[0-9]{1}\.?[0-9]{0,2})"
        For Each Item In .Execute(sr)
            brr(m, 5) = Item
        Next
    End With

        brr(m, 6) = Replace(.Cell(7, 2).Range.Text, Chr$(13) & Chr$(7), "")
      End With
      .Close
    End With
    myname = Dir()
  Loop
  wordapp.Quit
  With Worksheets("sheet1")
    .UsedRange.Offset(1, 0).Clear
    [c2:c1000].NumberFormatLocal = "@"
    .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    r = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Range("a1:f" & r).Borders.LineStyle = xlContinuous
  End With
End Sub