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