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

jiminyanyan

序号哪里来的。。。。

乐乐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 brr(1 To 10000, 1 To 5)
  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
      With .Tables(1)
        m = m + 1
        brr(m, 1) = Replace(.Cell(3, 2).Range.Text, Chr$(13) & Chr$(7), "")
        brr(m, 2) = Replace(.Cell(3, 6).Range.Text, Chr$(13) & Chr$(7), "")
        brr(m, 3) = Replace(.Cell(6, 2).Range.Text, Chr$(13) & Chr$(7), "")
        brr(m, 5) = 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("b2").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

约定的童话

乐乐2006201505 发表于 2019-3-20 22:42
Sub test()  'http://club.excelhome.net/thread-1352166-1-1.html
    For Each Process In GetObject("w ...

大师这代码没有弹窗提示，后台静默运行，比较不错，遗憾的是时间也弄不出来啊

约定的童话

jiminyanyan 发表于 2019-3-20 21:37
序号哪里来的。。。。

现在都卡在建档时间提取上面，不知大师有何高见？

weizxh

约定的童话 发表于 2019-3-20 17:45
这题着实困难啊，序号跟建档时间没法弄，其他的都可以提取出来

大佬，你这个也不错啊，可以发给我么

weizxh

mhps159357 发表于 2019-3-20 21:04
先引用Microsoft word 12.0(或14.0、11.0) object library  再运行下面代码
Sub cc()
Dim st$

我用的是office2003，怎么引入呢？

weizxh

乐乐2006201505 发表于 2019-3-20 22:42
Sub test()  'http://club.excelhome.net/thread-1352166-1-1.html
    For Each Process In GetObject("w ...

感谢大佬，我试一下效果，  另外问下office2003可以用么

weizxh

乐乐2006201505 发表于 2019-3-20 22:42
Sub test()  'http://club.excelhome.net/thread-1352166-1-1.html
    For Each Process In GetObject("w ...

测试后回来感谢大佬，确实有用。  除了时间提取不出来

mzbao

Sub ReadFromWord()
    Dim oDoc As Object
    Dim myPath$, MyName$, k%, JDDate$, arr(), i%, j%

    Range("A2:F2000").ClearContents
    myPath = ThisWorkbook.Path & "\"
    MyName = Dir(myPath & "*.doc*")
    k = 1
    Do While MyName <> ""
        If InStr(1, MyName, "农户信用(经济)档案") Then
            Set oDoc = GetObject(myPath & MyName)
            k = k + 1
            Cells(k, 1) = k - 1
            Cells(k, 2) = oDoc.Tables(1).Cell(3, 2).Range.Text
            Cells(k, 3) = oDoc.Tables(1).Cell(3, 6).Range.Text
            Cells(k, 4) = oDoc.Tables(1).Cell(6, 2).Range.Text
            JDDate = oDoc.Paragraphs(3).Range.Text
            JDDate = Split(Split(JDDate, " ")(0), "：")(1)
            Cells(k, 5) = JDDate
            Cells(k, 6) = oDoc.Tables(1).Cell(7, 2).Range.Text
            oDoc.Close True
        End If
        MyName = Dir
    Loop


    '删除黑点
    arr = Range("A2:F" & k).Value
    For i = 1 To UBound(arr)
        For j = 2 To 6
            If j <> 5 Then
                arr(i, j) = Left(arr(i, j), Len(arr(i, j)) - 1)
            End If
        Next j
    Next
    Range("A2:F" & k) = arr
End Sub

weizxh

mzbao 发表于 2019-3-21 09:38
Sub ReadFromWord()
    Dim oDoc As Object
    Dim myPath$, MyName$, k%, JDDate$, arr(), i%, j%

感谢大佬的技术分享，不过代码的简洁程度没有上面大佬的直观。  依然感谢无私帮助我的人