[已解决]从WORD表中提取内容到EXCEL

爱疯

说明：

1、有多个WORD文档，格式一样。

2、把指定内容（比如1.doc中的黄色填充），依次提取到结果表的a,b,c,d,e,f列。(如果指定无内容，就不提取)

3、结果表标题行可不管。




新建文件夹.rar (28.89 KB, 下载次数: 774)

2011-11-22 11:03 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuts

2011-11-22 11:45

Sub aa()
    On Error Resume Next
    Dim rep As New RegExp, mac, sr As String, x As Integer, fname As String, filename
    Dim xls As Object
    Set xls = ThisWorkbook.Sheets("Sheet1")
    fname = Dir(ThisWorkbook.Path & "\*.doc")
    Do
        x = x + 1
        fname = Dir
    Loop Until fname = ""
    For i = 1 To x
        filename = ThisWorkbook.Path & "\" & i & ".doc"
        Set doc = GetObject(filename)
        xls.Cells(i + 1, 1) = Left(doc.Tables(1).cell(2, 2), Len(doc.Tables(1).cell(2, 2)) - 1)
        xls.Cells(i + 1, 2) = Left(doc.Tables(1).cell(3, 2), Len(doc.Tables(1).cell(3, 2)) - 1)
        xls.Cells(i + 1, 3) = Left(doc.Tables(1).cell(8, 2), Len(doc.Tables(1).cell(8, 2)) - 1)
        xls.Cells(i + 1, 4) = Left(doc.Tables(1).cell(8, 4), Len(doc.Tables(1).cell(8, 4)) - 1)
        xls.Cells(i + 1, 5) = Left(doc.Tables(1).cell(12, 4), Len(doc.Tables(1).cell(12, 4)) - 1)
        sr = doc.Tables(1).cell(17, 2)
        With rep
            .Global = True
            .MultiLine = True
            .Pattern = "(\d+\.){3}\d+"
            Set mac = .Execute(sr)
        End With
        xls.Cells(i + 1, 6) = mac(0) & "/" & mac(1)
    Next
    Set rep = Nothing
End Sub

提取word字符，我这里老多出一个黑点在最后，所以用left截取了一下 没问题，可取消left
 

跳转到最佳答案楼层

菜鸟锐

等高手出现了~~帮你顶一下{:3912:}

上清宫主

MsgBox ActiveDocument.Tables(1).Cell(2, 2) '单位名称
MsgBox ActiveDocument.Tables(1).Cell(3, 2) '地址
MsgBox ActiveDocument.Tables(1).Cell(8, 4) '电话
其余折腾去吧

爱疯

上清宫主 发表于 2011-11-22 11:24
MsgBox ActiveDocument.Tables(1).Cell(2, 2) '单位名称
MsgBox ActiveDocument.Tables(1).Cell(3, 2) '地 ...

谢谢上清！
可以这样表示呀，学习了！
为什么每个返回值最后都有1个黑圆点呀？

上清宫主

好象从表格中取出来的都这样，具体机制不清楚（是结束符？）。可以将他取消了吧。

liuts

Sub aa()
    On Error Resume Next
    Dim rep As New RegExp, mac, sr As String, x As Integer, fname As String, filename
    Dim xls As Object
    Set xls = ThisWorkbook.Sheets("Sheet1")
    fname = Dir(ThisWorkbook.Path & "\*.doc")
    Do
        x = x + 1
        fname = Dir
    Loop Until fname = ""
    For i = 1 To x
        filename = ThisWorkbook.Path & "\" & i & ".doc"
        Set doc = GetObject(filename)
        xls.Cells(i + 1, 1) = Left(doc.Tables(1).cell(2, 2), Len(doc.Tables(1).cell(2, 2)) - 1)
        xls.Cells(i + 1, 2) = Left(doc.Tables(1).cell(3, 2), Len(doc.Tables(1).cell(3, 2)) - 1)
        xls.Cells(i + 1, 3) = Left(doc.Tables(1).cell(8, 2), Len(doc.Tables(1).cell(8, 2)) - 1)
        xls.Cells(i + 1, 4) = Left(doc.Tables(1).cell(8, 4), Len(doc.Tables(1).cell(8, 4)) - 1)
        xls.Cells(i + 1, 5) = Left(doc.Tables(1).cell(12, 4), Len(doc.Tables(1).cell(12, 4)) - 1)
        sr = doc.Tables(1).cell(17, 2)
        With rep
            .Global = True
            .MultiLine = True
            .Pattern = "(\d+\.){3}\d+"
            Set mac = .Execute(sr)
        End With
        xls.Cells(i + 1, 6) = mac(0) & "/" & mac(1)
    Next
    Set rep = Nothing
End Sub

提取word字符，我这里老多出一个黑点在最后，所以用left截取了一下 没问题，可取消left
 

老糊涂

谢谢分享        

爱疯

谢谢上清和liuts！
{:25:}

jrtzxjh

版主我是一个门外汉看到这个帖子很激动，但是你上面的代码怎么用呢，是写程序还是用txt还是写在excel里呢，能不能写一个教程啊，等待版主赐教

variable

收藏一下，慢慢看