zoukankan      html  css  js  c++  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
    

      

  • 相关阅读:
    AE旋转
    AE2
    AE1
    面试
    TS 基础数据类型
    vue-cli结构介绍
    js异步加载的5种方式
    slot 插槽的使用
    使用组件的细节点
    Vue 条件渲染
  • 原文地址:https://www.cnblogs.com/nextseven/p/10440859.html
Copyright © 2011-2022 走看看