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

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