20190226_xlVba提取查新标题和关键词
Posted nextseven
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了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
以上是关于20190226_xlVba提取查新标题和关键词的主要内容,如果未能解决你的问题,请参考以下文章