批量提取WORD信息到EXCEL

Question

批量对word里的内容提取到EXCEL里，这里提供一串代码，需求有2个
1：在运行过程中WPS或Office 2016 都提示用户定义类型未定义，如图

2：此代码提取的内容较多，遇到内容多容易死掉，所以只提取少量内容，工卡号，标题，DRWING TABLE里的内容：包含图纸号和版本，提取到EXCEL里。
如

图，需要提取图片中标红内容，DRWING TABLE内容可能跨页。

Public Function PickFolder() As String
   
        'FileDialogΪÎļþ¶Ô»°¿ò¶ÔÏ󣬿ÉÒÔÉèÖóɣ¬´ò¿ª¶Ô»°¿ò£¬Áí´æΪ¶Ô»°¿ò£¬ÎļþÑ¡È¡£¬Îļþ¼ÐÑ¡È¡
        Dim fd As FileDialog
        Dim strPath As String
       
        Set fd = Application.FileDialog(msoFileDialogFolderPicker) 'msoFileDialogFolderPicker±íÑ¡È¡Îļþ¼ÐµÄÐÎʽ
        fd.Title = "ÇëÑ¡ÔñÎļþ¼Ð"
        
        fd.InitialFileName = ThisWorkbook.Path & "\"
        
        
        'ÏÔʾ¶Ô»°¿ò£¬µ±Óû§µã»÷È·¶¨ºó£¬·µ»Ø-1
        If fd.Show = -1 Then
            strPath = fd.SelectedItems(1)
            
        Else
            strPath = ""
        End If
        Set fd = Nothing
        
        PickFolder = strPath
        
       
End Function

Function PickFolder1() As String
    Dim Sl As Object, Path As String
    
    
    Dim Ar, I As Long
    Set Sl = CreateObject("shell.application")
    Set folder = Sl.BrowseForFolder(0, "ÇëÑ¡ÔñÎļþ¼Ð", 0, ThisWorkbook.Path & "\") '´ò¿ª¶Ô»°¿ò
    If folder Is Nothing Then
        Path = ""
    Else
        Path = folder.Items.Item.Path        '»ñµÃÑ¡ÔñµÄ·¾¶
    End If
   Set Sl = Nothing
   Set folder = Nothing
   PickFolder1 = Path
    
    
End Function


Sub ReadFile()

'¹¤¾ß---ÒýÓã¬Ìí¼ÓMicrsoft Word 14.0 Object Library
'Set wd = CreateObject("word.application")
'Set dc = CreateObject("word.document")
'ÕâÑùµÄ¸ñʽ¸üºÃһЩ£¬µ«È±ÉÙÌáʾ£¬ÊìÁ·ÕßʹÓÃ


'Ñ¡ÔñÎļþ¼Ð£¬»òÖ±½Óд¶¼¿É
'    dpath = PickFolder1()
'    dpath = ThisWorkbook.Path & "\aaa"
    dpath = PickFolder()
    
    If dpath = "" Then Exit Sub
    
    
    Dim wdapp As Word.Application
    Dim wddocument As Word.Document
    Set wdapp = New Word.Application
    'wdapp.Visible = True
    
'    Application.ScreenUpdating = False
    
    'dir¿ÉÓÃÀ´ÅжÏÎļþÊÇ·ñ´æÔÚ£¬Ê¹ÓÃÁËͨÅä·û£¬doc£¬docx¶¼°üÀ¨ÁË£¬dirµÄƪ·ùºÜ¶àÇëÍøÂçËÑË÷²é¿´
    FileName = Dir(dpath & "\*.doc*")
    
    Dim temp As String
    
    On Error Resume Next
    Do While FileName <> ""

        Set wddocument = wdapp.Documents.Open(dpath & "\" & FileName) '½«´ò¿ªµÄÎļþ¸³¸øwddocument
        
        
        If wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Rows.Count = 2 Then
            If Cells(Cells.Rows.Count, 1).End(xlUp).Row > 1 Then
                r = Cells(Cells.Rows.Count, 1).End(xlUp).Row + 1
            Else
                r = 2
            End If
            
            If r = 2 Then Range("a" & r) = 1 Else Range("a" & r) = Range("a" & r - 1) + 1
            Range("b" & r) = Left(FileName, InStr(FileName, ".") - 1)
            Range("b" & r).Select
            
    
            
            '¸ù¾Ý¿Í»§ÌîдµÄwordÎļþ¸ñʽ£¬°ÑÊý¾Ý´ÓwordÎļþµÄÏàÓ¦tableÖÐÈ¡³ö£¬¼Ç¼µ½Excel µÄÏàӦλÖÃ
            
            'Range("c" & r) = Replace(wddocument.Tables(2).Cell(2, 2).Range.Text, Chr$(13) & Chr$(7), "")ÕâÑùдҲ¿ÉÒÔ£¬µÀÀíÒ»Ñù£¬Ö÷ÒªÊÇÈ¥µô¿ØÖÆ·û
            
            
             Range("c" & r) = Trim(Replace(wddocument.Tables(2).Cell(2, 2).Range.Text, vbCr & "", ""))
            Range("d" & r) = Trim(Replace(wddocument.Tables(2).Cell(2, 4).Range.Text, vbCr & "", ""))
            Range("e" & r) = Trim(Replace(wddocument.Tables(2).Cell(5, 1).Range.Text, vbCr & "", ""))
            Range("f" & r) = Trim(Replace(wddocument.Tables(2).Cell(5, 2).Range.Text, vbCr & "", ""))
            Range("g" & r) = Trim(Replace(wddocument.Tables(2).Cell(5, 3).Range.Text, vbCr & "", ""))
            Range("h" & r) = Trim(Replace(wddocument.Tables(2).Cell(5, 4).Range.Text, vbCr & "", ""))
    
    
            Range("i" & r) = Trim(Replace(wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 2).Range.Text, vbCr & "", ""))
            Range("j" & r) = Trim(Replace(wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 4).Range.Text, vbCr & "", ""))
            Range("k" & r) = Trim(Replace(wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(2, 2).Range.Text, vbCr & "", ""))
    
            Range("l" & r) = Trim(Replace(wddocument.Tables(1).Cell(2, 1).Range.Text, vbCr & "", ""))
            Range("m" & r) = Trim(Replace(wddocument.Tables(1).Cell(2, 2).Range.Text, vbCr & "", ""))
            Range("n" & r) = Trim(Replace(wddocument.Tables(1).Cell(2, 3).Range.Text, vbCr & "", ""))
            Range("o" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 1).Range.Text, vbCr & "", ""))
            Range("p" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 2).Range.Text, vbCr & "", ""))
            Range("q" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 3).Range.Text, vbCr & "", ""))
            Range("r" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 4).Range.Text, vbCr & "", ""))
            
            Range("s" & r) = Trim(Replace(wddocument.Tables(4).Cell(2, 3).Range.Text, vbCr & "", ""))
            
            Range("t" & r) = wddocument.Range.Information(wdNumberOfPagesInDocument)
            Range("u" & r) = Trim(Replace(wddocument.Tables(3).Cell(2, 2).Range.Text, vbCr & "", ""))
            Range("v" & r) = Trim(Replace(wddocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 1).Range.Text, vbCr & "", ""))
        Else
            If Sheet2.Cells(Sheet2.Cells.Rows.Count, 1).End(xlUp).Row > 1 Then
                r = Sheet2.Cells(Sheet2.Cells.Rows.Count, 1).End(xlUp).Row + 1
            Else
                r = 2
            End If
            
            'If r = 2 Then Sheet2.Range("a" & r) = 1 Else Sheet2.Range("a" & r) = Sheet2.Range("a" & r - 1) + 1
            'Sheet2.Range("b" & r) = FileName
            
            'Sheet2.Range("c" & r) = Trim(Replace(wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 3).Range.Text, vbCr & "", ""))
            'Sheet2.Range("d" & r) = Trim(Replace(wddocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(3, 3).Range.Text, vbCr & "", ""))
            
            'Sheet2.Range("e" & r) = Trim(Replace(wddocument.Tables(1).Cell(1, 2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("f" & r) = Trim(Replace(wddocument.Tables(1).Cell(2, 2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("g" & r) = Trim(Replace(wddocument.Tables(1).Cell(3, 1).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("h" & r) = Trim(Replace(wddocument.Tables(1).Cell(3, 2).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("i" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 1).Range.Paragraphs(3).Range.Text, vbCr & "", "")) 'mod
            'Sheet2.Range("j" & r) = Trim(Replace(wddocument.Tables(1).Cell(4, 2).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("k" & r) = Trim(Replace(wddocument.Tables(1).Cell(5, 3).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("l" & r) = Trim(Replace(wddocument.Tables(1).Cell(5, 4).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            
            'Sheet2.Range("m" & r) = Trim(Replace(wddocument.Tables(1).Cell(6, 1).Range.Paragraphs(2).Range.Text, "", "")) 'new
            'Sheet2.Range("n" & r) = Trim(Replace(wddocument.Tables(1).Cell(7, 1).Range.Text, "", "")) 'new
            'Sheet2.Range("o" & r) = Trim(Replace(wddocument.Tables(1).Cell(6, 2).Range.Paragraphs(2).Range.Text, "", "")) 'new
            'Sheet2.Range("p" & r) = Trim(Replace(wddocument.Tables(1).Cell(7, 2).Range.Text, "", "")) 'new
            'Sheet2.Range("q" & r) = Trim(Replace(wddocument.Tables(1).Cell(6, 3).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("r" & r) = Trim(Replace(wddocument.Tables(1).Cell(7, 3).Range.Text, "", "")) 'new
            
            'Sheet2.Range("s" & r) = Trim(Replace(wddocument.Tables(2).Cell(2, 1).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("t" & r) = Trim(Replace(wddocument.Tables(2).Cell(2, 2).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("u" & r) = Trim(Replace(wddocument.Tables(2).Cell(2, 3).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("v" & r) = Trim(Replace(wddocument.Tables(2).Cell(3, 1).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("w" & r) = Trim(Replace(wddocument.Tables(2).Cell(3, 2).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            'Sheet2.Range("x" & r) = Trim(Replace(wddocument.Tables(2).Cell(3, 3).Range.Paragraphs(2).Range.Text, vbCr & "", ""))
            
            'Sheet2.Range("y" & r) = Trim(Replace(wddocument.Tables(4).Cell(2, 1).Range.Text, vbCr & "", ""))
            'Sheet2.Range("z" & r) = Trim(Replace(wddocument.Tables(4).Cell(4, 1).Range.Text, vbCr & "", ""))
            'Sheet2.Range("aa" & r) = Trim(Replace(wddocument.Tables(4).Cell(6, 1).Range.Text, vbCr & "", ""))
            'Sheet2.Range("ab" & r) = Trim(Replace(wddocument.Tables(4).Cell(8, 1).Range.Text, vbCr & "", ""))
            'Sheet2.Range("ac" & r) = Trim(Replace(wddocument.Tables(4).Cell(10, 1).Range.Text, vbCr & "", ""))
            
            'Sheet2.Range("ad" & r) = Trim(Replace(wddocument.Tables(5).Cell(2, 3).Range.Text, vbCr & "", ""))
           
        End If
        
        
        
        

        wddocument.Close
        Set wddocument = Nothing
        

        FileName = Dir() 'Öظ´ÏÂÒ»¸öÎļþ£¬dirµÄƪ·ùºÜ¶àÇëÍøÂçËÑË÷²é¿´
    Loop
    
'errH:
    Set wddocument = Nothing
    wdapp.Quit
    Set wdapp = Nothing
    Application.ScreenUpdating = True

End Sub

Sub kill()
For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='winword.EXE'")
        Process.Terminate (0)
Next
End Sub

Answer 1

以下内容由AIGC及阿里嘎多学长共同生成、有用望采纳：

---

根据您提供的信息和需求，我将给出一个基于VBA的解决方案，用于批量从Word文档中提取特定信息到Excel中。以下是解决方案的步骤和示例代码：

解决方案步骤：

1. 修正用户定义类型未定义的问题：确保VBA项目中引用了Microsoft Word 14.0 Object Library。

2. 优化代码效率：通过设置Word和Excel的ScreenUpdating和DisplayAlerts属性为False来减少资源消耗。

3. 提取特定内容：根据Word文档中的结构，定位到需要提取的信息，并将其保存到Excel中。

示例代码：

Sub ExtractWordInfoToExcel()
    Dim wdApp As Object ' 定义Word Application对象
    Dim wdDocs As Object ' 定义Word文档集合
    Dim wdDoc As Object ' 定义Word文档对象
    Dim ExcelApp As Object ' 定义Excel Application对象
    Dim ExcelWB As Object ' 定义Excel Workbook对象
    Dim ExcelSheet As Object ' 定义Excel Worksheet对象
    Dim FilePath As String ' 文件夹路径
    Dim FileName As String ' Word文档文件名
    Dim i As Long ' 循环计数器

    ' 创建Word和Excel应用程序对象
    Set wdApp = CreateObject("Word.Application")
    Set ExcelApp = CreateObject("Excel.Application")

    ' 设置Word和Excel不可见
    wdApp.Visible = False
    ExcelApp.Visible = True

    ' 打开新的Excel工作簿
    Set ExcelWB = ExcelApp.Workbooks.Add
    Set ExcelSheet = ExcelWB.Sheets(1)

    ' 选择包含Word文档的文件夹
    FilePath = PickFolder()
    If FilePath = "" Then
        MsgBox "没有选择文件夹", vbExclamation
        Exit Sub
    End If

    ' 循环遍历文件夹中的Word文档
    FileName = Dir(FilePath & "\*.doc*", vbNormal)
    Do While FileName <> ""
        Set wdDoc = wdApp.Documents.Open(FilePath & "\" & FileName)

        ' 提取工卡号
        ExcelSheet.Cells(i + 1, 1).Value = wdDoc.BuiltInDocumentProperties("Title")

        ' 提取标题
        ExcelSheet.Cells(i + 1, 2).Value = wdDoc.BuiltInDocumentProperties("Subject")

        ' 提取图纸信息，这里需要根据实际文档结构调整
        ' 假设图纸信息在文档的第一个表格中
        If wdDoc.Tables.Count > 0 Then
            ExcelSheet.Cells(i + 1, 3).Value = wdDoc.Tables(1).Cell(1, 1).Range.Text
            ExcelSheet.Cells(i + 1, 4).Value = wdDoc.Tables(1).Cell(1, 2).Range.Text
        End If

        ' 关闭文档
        wdDoc.Close SaveChanges:=False
        FileName = Dir()
        i = i + 1
    Loop

    ' 保存Excel工作簿
    ExcelWB.SaveAs "ExtractedInfo.xlsx"

    ' 清理对象
    Set wdDoc = Nothing
    wdApp.Quit
    Set wdApp = Nothing
    ExcelWB.Close SaveChanges:=False
    ExcelApp.Quit
    Set ExcelWB = Nothing
    Set ExcelApp = Nothing

    MsgBox "信息提取完成！"
End Sub

Function PickFolder() As String
    ' 使用FileDialog选择文件夹路径
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.Title = "选择文件夹"
    If fd.Show = -1 Then
        PickFolder = fd.SelectedItems(1)
    Else
        PickFolder = ""
    End If
    Set fd = Nothing
End Function

注意事项：

• 示例代码中的PickFolder函数使用VBA的FileDialog对象来选择文件夹路径。
• 需要根据实际的Word文档结构调整提取信息的代码部分。
• 示例代码假设图纸信息在文档的第一个表格中，如果结构不同，需要相应调整。

示例输入和输出：

• 示例输入：一个包含多个Word文档的文件夹，每个文档包含工卡号、标题和图纸信息。
• 示例输出：一个Excel工作簿，其中包含从Word文档中提取的信息，保存为"ExtractedInfo.xlsx"。

请根据您实际的Word文档结构和需求，对上述代码进行适当的调整和完善。