Excel VBA 提取word表格信息（vba提取sheet名字）

有时候需提取word表格信息到Excel表，例如下表在Word里面，有很多类似word表格需要提取。

Excel中信息如下：

下面我们来用VBA实现关键信息获取：

Dim FileDic As Object
Sub Main()
    Dim FilePath As String
    Dim i As Integer, n As Integer
    Dim arr
    FilePath = ChooseFolder 

Set FileDic = CreateObject("scripting.dictionary")
Call FileSearchFso(FilePath)
    Application.ScreenUpdating = False
    Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")   '新建Word对象
    WordApp.Visible = True
    Dim WordD As Object
    ReDim arr(1 To FileDic.Count, 1 To 6)
    For Each k In FileDic.keys
        PicPath = k: n = n + 1
        Set WordD = WordApp.Documents.Open(PicPath)
        If WordD.tables.Count > 0 Then
            With WordD.tables(1)
                arr(n, 2) = Replace(WordD.tables(1).Cell(1, 3).Range.Text, Chr(13) & Chr(7), "") '建设单位
                arr(n, 3) = Replace(WordD.tables(1).Cell(1, 5).Range.Text, Chr(13) & Chr(7), "")  '工程名称
                arr(n, 4) = Replace(WordD.tables(1).Cell(2, 3).Range.Text, Chr(13) & Chr(7), "")  '建筑面积
                arr(n, 5) = Replace(WordD.tables(1).Cell(2, 5).Range.Text, Chr(13) & Chr(7), "")  '工程造价
                arr(n, 6) = Replace(WordD.tables(1).Cell(3, 3).Range.Text, Chr(13) & Chr(7), "")  '工程地点
End With
End If
With WordD.Paragraphs(2).Range.Find
            .Text = "日期："
If .Execute Then
                arr(n, 1) = WordD.Range(.Parent.End, WordD.Paragraphs(2).Range.End - 1).Text
End If
End With
        WordD.Close
Next
Set WordD = Nothing
    WordApp.Quit
Range("a3").Resize(n, 6) = arr
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

Private Function ChooseFolder() As String    '选择文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            ChooseFolder = .SelectedItems(1)
        Else
            End
        End If
    End With
End Function

Private Sub FileSearchFso(myPath As String)  '遍历文件夹下的所有doc,docx文件
    Dim Fso As Object, Folder As Object
    Dim FileCollection As Object, fileName As Object
Set Fso = CreateObject("scripting.filesystemobject")
Set Folder = Fso.GetFolder(myPath)
Set FileCollection = Folder.Files
For Each fileName In FileCollection
If fileName Like "*.doc*" And Left(fileName.shortname, 2) <> "~#34; Then
            FileDic(fileName.Path) = ""
End If
Next
End Sub

其中2和自定义函数，可以当作备份和后期用于其他遍历也可直接使用。Excel提取word表格信息相对简单，因为定位内容相对方便，如果是提取word里面非表格的信息就略微麻烦，有时候会用到正则，具体可见之前发的提取word里面括号内容到Excel。

这里简单分享下VBA正则表达式，跟大家一起学习。

正则表达式（Regular Expression），常被用来检验、替换符合某个模式(规则)的字符串，在代码中常缩写为regexp。
VBA中并没有直接提供正文表达式对象，需要借助VBScript的正则对象。一般使用后期绑定的方式创建正则对象，代码如下：

Set objRegEx = CreateObject("vbscript.regexp")

正则对象有四个属性和三个方法。

至于怎么用，且待下回分享！！！