如何用vba把多个word文档的内容提取到excel中？

word和excel之间的数据转移是一个经常遇到的情形。

一般的提取word文档的内容到excel的步骤如下：

1.在excel中编写vba代码，创建word应用程序对象

2.打开word文档（此步骤可以设置固定的文件路径，也可以设置自定义选择文件路径）

3.读取word文档中的内容到变量

4.如果还涉及到word文档内容的改写，还需要把变量的值回写到word文档中

5.将变量的值写入到excel中

6.保存word文档

7.关闭word文档

8.如果不止一个word文档，则循环步骤2到步骤7

9.释放步骤1中创建的word应用程序对象

10.在excel中处理提取的内容

11.处理完毕

基于以上的步骤，我们可以写出如下的通用的提取word内容到excel表格中的代码：

Dim oWord As Object
Sub QQ1722187970()
    Set oWord = VBA.CreateObject("word.application")
    oWord.Visible = True
    Dim sPath As String
    '获取文件或者文件夹的路径
    sPath = GetPath()
    If Len(sPath) Then
        Call EnuAllFiles(sPath)
    End If
    '释放word应用程序对象
    Set oWord = Nothing
    MsgBox "处理完成!!!"
End Sub
Function GetPath() As String
    '声明一个FileDialog对象变量
    Dim oFD As FileDialog
'    '创建一个选择文件对话框
'    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    '创建一个选择文件夹对话框
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    '声明一个变量用来存储选择的文件名
    Dim vrtSelectedItem As Variant
    With oFD
        '允许选择多个文件
        .AllowMultiSelect = True
        '使用Show方法显示对话框，如果单击了确定按钮则返回-1。
        If .Show = -1 Then
            '遍历所有选择的文件
            For Each vrtSelectedItem In .SelectedItems
                '获取所有选择的文件的完整路径,用于各种操作
                GetPath = vrtSelectedItem
            Next
            '如果单击了取消按钮则返回0
        Else
        End If
    End With
    '释放对象变量
    Set oFD = Nothing
End Function
Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
    Dim oWK As Worksheet
    Set oWK = Excel.Worksheets("Sheet1")
    With oWK
        Dim arr
        '设置列标题
        arr = Array("姓名", "出生年月", "年龄", "学历", "现任职务")
        .Cells.Clear
        iCol = UBound(arr) + 1
        .Range("a1").Resize(1, iCol) = arr
        '从第2行开始填充提取的内容
        i = 2
    End With
    '定义文件系统对象
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    '定义文件夹对象
        Dim oFolder As Object
    Set oFolder = oFso.GetFolder(sPath)
    '定义文件对象
    Dim oFile As Object
    '如果指定的文件夹含有文件
    If oFolder.Files.Count Then
        For Each oFile In oFolder.Files
            With oFile
                '输出文件所在的盘符
                Dim sDrive As String
                sDrive = .Drive
                '输出文件的类型
                Dim sType As String
                sType = .Type
                '输出含后缀名的文件名称
                Dim sName As String
                sName = .Name
                '输出含文件名的完整路径
                Dim sFilePath As String
                sFilePath = .Path
                '如果文件是Word文件且不是隐藏文件
                If sType Like "*ord*" And .Attributes <> 2 Then
                    '以下是对每个文件进行处理的代码
                    '*********************************
                    Debug.Print sFilePath
                    '打开word文档
                    Set oDoc = oWord.Documents.Open(sFilePath)
                    With oDoc
                    '提取代码***********************'
                    '保存word文档
                    .Save
                    '关闭word文档
                    .Close
                    '接着下一个word文档
                    i = i + 1
                    End With
                Else
                End If
            End With
        Next
    '如果指定的文件夹不含有文件
    Else
    End If
    '如果要遍历子文件夹
    If bEnuSub = True Then
        '定义子文件夹集合对象
        Dim oSubFolders As Object
        Set oSubFolders = oFolder.SubFolders
        If oSubFolders.Count > 0 Then
            For Each oTempFolder In oSubFolders
                sTempPath = oTempFolder.Path
                Call EnuAllFiles(sTempPath, True)
            Next
        End If
        Set oSubFolders = Nothing
    End If
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFso = Nothing
End Sub