java抓取热门分类标题_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