利用ExcelVBA提取word中的数据

sw3392787

Moneky 发表于 2018-4-4 12:53
不需要导入的格子清空，你看看我的示例文档就知道了。

那样太费事，我有100多个文档，我要一个个删除，那我还不如一个个复制粘贴到表格

Moneky

sw3392787 发表于 2018-4-4 14:31
那样太费事，我有100多个文档，我要一个个删除，那我还不如一个个复制粘贴到表格

只是模版需要删除不需要的部分，又不是每个文档都要删除。
当然了，如果你100多个文档每个文档中表格结构都不一样的话，当我没说。

182197315

sw3392787 发表于 2018-4-4 12:24
您的意思是指，比如把Excel的第2行，第1列是姓名将其标红，然后同时在word对应姓名那里也标红对吗？以此 ...

是的                        

182197315

Sub test()
Dim i%, k%, myPath$, myFile$, arr(1 To 100, 1 To 29)
Dim wdApp As New Word.Application
Dim wdD As Word.Document
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.doc?")
Do While myFile <> ""
    i = i + 1
    Set wdD = wdApp.Documents.Open(myPath & myFile)
    With wdD.Tables(1)
        arr(i, 6) = Replace(Replace(.Cell(1, 3).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 8) = Replace(Replace(.Cell(2, 5).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 9) = Replace(Replace(.Cell(1, 5).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 10) = Replace(Replace(.Cell(1, 7).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 11) = Replace(Replace(.Cell(6, 3).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 12) = Replace(Replace(.Cell(7, 5).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 13) = Replace(Replace(.Cell(7, 3).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 14) = Replace(Replace(.Cell(3, 5).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 15) = Replace(Replace(.Cell(4, 3).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 16) = Replace(Replace(.Cell(4, 5).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 17) = Replace(Replace(.Cell(5, 3).Range.Text, Chr(7), ""), Chr(13), "")
        arr(i, 18) = Replace(Replace(.Cell(3, 3).Range.Text, Chr(7), ""), Chr(13), "")
     End With
    myFile = Dir
Loop
wdD.Close
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Range("A2").Resize(UBound(arr), 29) = arr
End Sub

费用        班次        考试期这三项不知道从哪里提取

opiona

sw3392787 发表于 2018-4-4 12:37
暂时还没研究懂代码，在此请教，好像身份证号码、毕业院校等没有提取到？这些是没些代码还是提取过程出错 ...

这里是你要提取的内容，在Excel中是第几列，你可以无限添&#13641;加

Arx和Brx 是这个内容在Word表格所在单元格的行数和列数，

数组元素个数和Crx要对应

例如 ：身份证 在Excel第15列，在word中是单元格（3,4）
在crx，arx，brx分别加入：，15   ，3   ，4

没有提取到可能是表格单元格行列不一致，那就没办法了！

乐乐2006201505

在四楼大师代码基础上做的，看看是不是你想要的。
'*********************************
'*******  北极狐工作室出品  ******
'*******  QQ：14885553      ******
'*********************************
Sub Opiona()
    Dim s As String
    Rem 禁止系统刷屏?触发其他事件等
    'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = True   '关闭系统状态条
    For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
            Process.Terminate (0)
    Next
    Set WordApp = CreateObject("word.application")
    Set shx = Worksheets("Sheet1")
    ARX = Split("1,1,1,2,6,7,5,3,4,4,5,3", ",")    '//所在Word表格 行数，个数和顺序和Excel列对应
    BRX = Split("3,5,7,5,3,5,7,5,3,5,5,3", ",")    '//所在Word表格 列数
    CRX = Split("6,9,10,8,11,12,13,14,15,16,17,18", ",")  '//在Excel中放到第几列
    shx.Columns(8).NumberFormat = "@"
    FileArr = FileAllArr(ThisWorkbook.Path, "*.DOC?", ThisWorkbook.Name, True, False)
    For i = 0 To UBound(FileArr)
        WordApp.Visible = False  '关闭word文档的显示
        Set Worddoc = WordApp.Documents.Open(FileArr(i))
        Set WordTable = Worddoc.Tables(1) '指向第一张WORD表格
        Rem 每个需要的单元格
        For X = 0 To UBound(ARX)
            Set Cell = WordTable.Cell(Val(ARX(X)), Val(BRX(X)))
            If Not Cell Is Nothing Then     '如果单元格存在
                shx.Cells(i + 2, Val(CRX(X))).Value = Replace(Replace(Replace(Replace(Cell.Range.Text, Chr(7), ""), Chr(10), ""), Chr(13), ""), vbCrLf, "")
            End If
        Next
        Rem 南山 福田 龙华 宝安 龙岗班
        STR1 = "南山,福田,龙华,宝安,龙岗班"
        With Worddoc.Content.Find
            .Highlight = True
            Do While .Execute
            Debug.Print "|" & .Parent.Text & "|"
                If InStr(STR1, Replace(Replace(.Parent.Text, "(", ""), " ", "")) > 0 Then
                    shx.Cells(i + 2, 23).Value = Replace(Replace(.Parent.Text, "(", ""), " ", "")
                    Exit Do
                End If
            Loop
        End With
        With Worddoc.Content.Find
            '顺着找
            .Font.Underline = wdUnderlineSingle
            Do While .Execute(FindText:="", Format:=True)
                s = s & .Parent & ","
            Loop
        End With
        '倒回去替换
        h = Split(s, ",")
        If h(21) <> "" Then
            shx.Cells(i + 2, 24).Value = Replace(Trim(h(21)), " ", "")
            If h(6) <> "" Then
                shx.Cells(i + 2, 21).Value = Replace(Trim(h(6)), " ", "")
            End If
        End If
        WordApp.Visible = True   '关闭word文档的显示
        Worddoc.Close False
    Next
    WordApp.Quit
    Set Worddoc = Nothing
    shx.Columns(8).AutoFit
    Application.StatusBar = False   '恢复系统状态条
    Application.EnableEvents = True  '//  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
    MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
End Sub

'*******************************************************************************************************
'功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名：  FileAllArr
'参数1：   Filename    需查找的文件夹名，不包含文件名
'参数2：   FileFilter  需要过滤的文件名，可省略，默认为：[*.*]
'参数3：   Liwai       剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'参数4：   SubFiles    是否需要查找子文件夹内文件，可省略，默认为：true
'参数5：   Files       是否只要文件夹名，可省略，默认为：FALSE
'返回值：  一个字符型的数组
'使用方法：FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false,false)
'作者:    北极狐工作室 QQ：14885553
'*******************************************************************************************************
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal SubFiles As Boolean = True, Optional ByVal Files As Boolean = False) As String()
    Dim DIC, Ke, MyName, MyFileName
    Dim i As Long
    Set DIC = CreateObject("Scripting.Dictionary")    '创建一个字典对象，保存文件夹路径
    Filename = Replace(Replace(Filename & "\", "\\", "\"), "\\", "\")  '//如果没有，文件夹名后面补上：\
    DIC.Add (Filename), ""
    i = 0
    Do While i < DIC.Count
        Ke = DIC.keys   '开始遍历字典
        If SubFiles = True Then  '//如果需要查找子文件夹
            MyName = Dir(Ke(i), vbDirectory)    '查找目录
            Do While MyName <> ""
                If MyName <> "." And MyName <> ".." Then
                    If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                        DIC.Add (Ke(i) & MyName & "\"), ""  '就往字典中添加这个次级目录名作为一个条目
                    End If
                End If
                MyName = Dir    '继续遍历寻找
            Loop
        End If
        i = i + 1
    Loop
    Dim Arrx() As String  '//定义一个数组，用于输出
    i = 0
    ReDim Preserve Arrx(i)
    Arrx(0) = ""   '//初始化，避免出错，没有就是：空白
    If Files = True Then   '//是否只输出文件夹名
        For Each Ke In DIC.keys    '以查找总表所在文件夹下所有excel文件为例
            ReDim Preserve Arrx(i)
            If Ke <> Filename Then   '//自身文件夹除外
                Arrx(i) = Ke
                i = i + 1
            End If
        Next
        FileAllArr = Arrx
    Else
        For Each Ke In DIC.keys    '以查找总表所在文件夹下所有excel文件为例
            MyFileName = Dir(Ke & FileFilter)    '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
            Do While MyFileName <> ""
                If MyFileName <> Liwai Then    '排除例外文件
                    ReDim Preserve Arrx(i)
                    Arrx(i) = Ke & MyFileName
                    i = i + 1
                End If
                MyFileName = Dir
            Loop
        Next
        FileAllArr = Arrx
    End If
End Function

'****************************************************************

zorsite

既然楼主意识到了要使用程序来自动化完成数据采集工作，那就应该再向前走一小步：改变word文档，使其录入的数据更规范，更易定位。这一步做好了，可以省却你很多的工作。
举个例子：
可以使用表格来使得获取数据更为容易，比如把word文档更改为如下格式（为了说明问题，我设置了表格边框。在实际工作中可以隐藏边框来美化表格）

比如要采集联系人和经手人，只需要定位到相应单元格即可，而不需要采用正则表达式来分析数据。
至于如何采集某一单元格的数据，见下帖：
http://club.excelhome.net/thread-1386296-1-1.html

还可以使用控件来帮助定位信息。
要获取学员是什么样的缴费方式、什么培训地点，可以采用控件。加入复选框或单选框控件，就可以通过控件的状态来判断该学员的相关信息了。
同样的道理，如果不希望用表格来排版，也可以设置文本控件，让学员把相关信息填写入文本控件，后期通过读取文本控件的内容来采集信息。

用word来记录信息最大的问题是目标信息的定位比较困难，如果全部是文本、段落的话，想要定位很麻烦。采用辅助对象（比如表格、控件、书签）来进行定位是一个比较好的方法。

sw3392787

zorsite 发表于 2018-4-6 19:59
既然楼主意识到了要使用程序来自动化完成数据采集工作，那就应该再向前走一小步：改变word文档，使其录入 ...

谢谢。对的。之前也看过类似的说法，所以在问题中也提出，如果要改word格式什么的也可以。
你说的这个办法确实是我在想进一步改进的。非常感谢。

sw3392787

乐乐2006201505 发表于 2018-4-6 18:32
在四楼大师代码基础上做的，看看是不是你想要的。
'*********************************
'*******  北极狐 ...

非常感谢，结合你的完整代码以及四楼大神的回复怎么改写，已经完全实现。
感谢各位大神们的帮助。

sw3392787

opiona 发表于 2018-4-5 18:29
这里是你要提取的内容，在Excel中是第几列，你可以无限添&#13641;加

Arx和Brx 是这个内容在Word表 ...

非常谢谢。你的回答完美解决我的问题。我也根据你说的以及16楼给出的，弄到提取的行列关系。谢谢谢谢