ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 607|回复: 0

如何根据关键字查找日语专利文档,并找到对应的中文文档

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-6-18 23:03 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Sub search()
    Range("c2:w1000").ClearContents
    Set JPfilePathes = CreateObject("scripting.dictionary")
    Set CNfilePathes = CreateObject("scripting.dictionary")
    startPrintLine = 2
    folderPath = addBackslash(Worksheets("search").Cells(4, 1))
    filePathes = searchAbiscoLog(folderPath)
    For i = 0 To UBound(filePathes)
        If InStr(Split(filePathes(i), "\")(UBound(Split(filePathes(i), "\"))), "-") = 0 Then
            JPfilePathes.Add filePathes(i), ""
        Else
            CNfilePathes.Add filePathes(i), ""
        End If
    Next
    For Each CNfile In CNfilePathes
        Debug.Print CNfile
    Next
    For Each sFName In JPfilePathes
        startPrintLine = searchKeyWords(CNfilePathes, sFName, startPrintLine)
    Next
End Sub

Function searchKeyWords(ByVal CNfilePathes, ByVal sFName, ByVal startPrintLine)
Debug.Print chineseVersionPath
    Set docApp = CreateObject("Word.Application")   '实例化Word对象变量
    docApp.Documents.Open sFName    '打开Word文档
    Keywords = Worksheets("search").Cells(7, 1)
    i = startPrintLine
    With docApp.ActiveDocument
        For Each pg In .Paragraphs  '处理Word中的每一个段落
            str1 = pg.Range.Text    '获取段落中的文本
            If InStr(str1, Keywords) > 0 Then
                Worksheets("search").Cells(i, 3) = sFName
                Worksheets("search").Cells(i, 7) = str1
                Cells(i, 7).Font.Color = vbBlack
                KeywordsStart = InStr(str1, Keywords)
                Cells(i, 7).Characters(KeywordsStart, Len(Keywords)).Font.Color = vbRed
                docName = Split(Split(sFName, "\")(UBound(Split(sFName, "\"))), ".")(0)
                Worksheets("search").Cells(i, 4) = Split(sFName, docName)(0)
                chineseVersionPath = getChineseVersion(docName, CNfilePathes)
                chineseFolder = Left(chineseVersionPath, Len(chineseVersionPath) - Len(Split(chineseVersionPath, "\")(UBound(Split(chineseVersionPath, "\")))))
                Worksheets("search").Cells(i, 5) = chineseVersionPath
                Worksheets("search").Cells(i, 6) = chineseFolder
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), Address:=Cells(i, 3).Value, TextToDisplay:=Split(Split(sFName, "\")(UBound(Split(sFName, "\"))), ".")(0)
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 4), Address:=Cells(i, 4).Value, TextToDisplay:="JP Folder"
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 5), Address:=Cells(i, 5).Value, TextToDisplay:=Split(Split(chineseVersionPath, "\")(UBound(Split(chineseVersionPath, "\"))), ".")(0)
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 6), Address:=Cells(i, 6).Value, TextToDisplay:="CN Folder"
                i = i + 1
                startPrintLine = i
            End If
        Next
    End With
    docApp.Quit '退出Word文档
    Set docApp = Nothing    '释放对象变量
'    Debug.Print startPrintLine
    searchKeyWords = startPrintLine
End Function
Function getChineseVersion(ByVal docName, ByVal CNfilePathes)
    Set CNmatchFilePathes = CreateObject("scripting.dictionary")
    If InStr(1, docName, "FCP") > 0 Then
        docNameChinese = docName & "-"
    End If
    If InStr(1, docName, "FS") > 0 Then
        docNameChineseA = docName & "-"
        docNameChineseA = Replace(docNameChineseA, "FS", "C")
        docNameChinesePA = Replace(docNameChineseA, "A", "PA")
    End If
    For Each filePath In CNfilePathes
        If (InStr(1, docName, "FCP") > 0 And InStr(1, filePath, docNameChinese) > 0) Or _
        (InStr(1, docName, "FS") > 0 And (InStr(1, filePath, docNameChineseA) > 0 Or InStr(1, filePath, docNameChinesePA) > 0)) Then
            getChineseVersion = filePath
            CNmatchFilePathes.Add filePath, ""
            Exit For
        End If
    Next
End Function


Function searchAbiscoLog(folderPath)
    Set folderlist = CreateObject("scripting.dictionary")
    Set FileList = CreateObject("scripting.dictionary")
    folderlist.Add folderPath, ""
    Do While folderlist.Count > 0
        For Each FolderName In folderlist.keys
        fname = Dir(FolderName, vbDirectory)
            Do While fname <> ""
                If fname <> ".." And fname <> "." Then
                    If GetAttr(FolderName & fname) And vbDirectory Then 'Here, all of the sub folders are treated as single fname,and the FolderName are changed while add the next sub folder
                            folderlist.Add FolderName & fname & "\", ""
                    Else
                            FileList.Add FolderName & fname, ""
                    End If
                End If
            fname = Dir
            Loop
        folderlist.Remove (FolderName)
        Next
    Loop
    searchAbiscoLog = FileList.keys
End Function

Function addBackslash(folderPath)
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If
    addBackslash = folderPath
End Function


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 16:56 , Processed in 0.039987 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表