20190226_xlVba提取查新标题和关键词

VBA批量读取Word文档至Excel

最新推荐文章于 2024-04-20 17:41:58 发布

转载最新推荐文章于 2024-04-20 17:41:58 发布 · 199 阅读

0 ·

CC 4.0 BY-SA版权

原文链接：http://www.cnblogs.com/nextseven/p/10440859.html

本文介绍了一种使用VBA编程批量从指定文件夹读取多个Word文档，并将文档中的特定信息汇总到Excel表格的方法。此过程涉及创建Word应用程序对象，打开并解析每个文档，提取包括中文标题、英文标题和关键词等信息，然后将其写入Excel的相应单元格中。

Sub MainProc()
    Dim Sht As Worksheet
    Dim Wb As Workbook
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets(1)
    Sht.Cells.Clear
    Sht.Range("A1:D1").Value = Array("中文标题", "英文标题", "关键词", "文件名称")
    'FolderPath = Wb.Path & "\指定文件夹\"
    FolderPath = FolderPicker
    If FolderPath = "" Then Exit Sub
    Filename = Dir(FolderPath & "*.doc*")
    Dim wdApp As Object
    Dim doc As Object
    Dim tb As Object
    Dim p As Object
    Dim keys As String
    Dim IsGet As Boolean
    Dim chnTitle As String
    Dim enTitle As String
    Set wdApp = CreateObject("Word.Application")
    counter = 1
    Do While Filename <> ""
        FilePath = FolderPath & Filename
        Set doc = wdApp.documents.Open(FilePath)
        IsGet = False
        keys = ""
        chnTitle = ""
        enTitle = ""
        counter = counter + 1
        With doc
            Set tb = .Tables(1)
            chnTitle = tb.Cell(1, 2).Range.Text
            enTitle = tb.Cell(2, 2).Range.Text
            For Each p In doc.Paragraphs
                i = i + 1
                ' Debug.Print i; "  "; p.Range.Text
                If p.Range.Text Like "*中文关键词*" Then IsGet = True
                If p.Range.Text Like "*查新项目的查新点*" Then IsGet = False
                If IsGet And Not p.Range.Text Like "*关键词*" Then
                    keys = keys & p.Range.Text
                End If
            Next
        End With
        
        Sht.Cells(counter, 1).Value = chnTitle
        Sht.Cells(counter, 2).Value = enTitle
        Sht.Cells(counter, 3).Value = keys
        Sht.Cells(counter, 4).Value = Filename
        doc.Close False
        Filename = Dir
    Loop
    wdApp.Quit
    Set wdApp = Nothing
    Set doc = Nothing
    Set Wb = Nothing
    Set Sht = Nothing
End Sub
Function FolderPicker() As String
    Dim FolderPath As String
   InitialPath = Application.ActiveWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = InitialPath
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
        End If
    End With
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    FolderPicker = FolderPath
End Function

转载于:https://www.cnblogs.com/nextseven/p/10440859.html