精华内容
下载资源
问答
  • 2022-03-12 14:15:13

    批量对关键字打标记(文件夹遍历)

    Option Explicit
    Private Const FINISHED_FILE_PATH As String = "newData\"         ' 存完成文件的目录名
    Private Const ERROR_FILE_PATH As String = "errorData\"          ' 存出错文件的目录名
    Private Const SKIP_FILE_PATH As String = "skipData\"            ' 存跳过文件的目录名
    Private Const ERROR_FILE_SUFFIX As String = "Err.log"           ' 出错日志后缀
    Private Const SKIP_FILE_SUFFIX As String = "Skip.log"           ' 跳过日志后缀
    Dim fs As Object                                                ' 文件系统对象
    Dim errLogFile As String                                        ' 错误日志
    Dim skipLogFile As String                                       ' 跳过记录的日志
    Dim sourceFilePath As String                                    ' 选择要处理的文件所在
     
    Sub 遍历文件夹中对文档的关键字打标记()
        On Error GoTo ErrorHandler
         
        Dim CurrPath$, CurrFile$, currDoc As Document, keyArray() As String, fileNameExtension As String, newPath As String, skipPath As String, errPath As String, tempFileName As String
        ' --------- 初始化 开始 ----------
        ' 选择要处理的文件所在
        If Not SelectFolder() Then Exit Sub
        If MsgBox("要处理的文件在:" & sourceFilePath, vbYesNo + vbInformation, "确认源文件目录") <> vbYes Then Exit Sub
        CurrPath = ThisDocument.path & "\"
        errLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", ERROR_FILE_SUFFIX)
        skipLogFile = CurrPath & Replace(ThisDocument.Name, ".docm", SKIP_FILE_SUFFIX)
        ' 准备文件夹
        newPath = CurrPath & FINISHED_FILE_PATH
        skipPath = CurrPath & SKIP_FILE_PATH
        errPath = CurrPath & ERROR_FILE_PATH
        If Dir(newPath, vbDirectory) = vbNullString Then MkDir newPath
        If Dir(skipPath, vbDirectory) = vbNullString Then MkDir skipPath
        If Dir(errPath, vbDirectory) = vbNullString Then MkDir errPath
        ' 初始化文件系统对象
        Set fs = CreateObject("Scripting.FileSystemObject")
        ' --------- 初始化 结束 ----------
        
        CurrFile = Dir(sourceFilePath)
    
        Do Until CurrFile = ""
            If CurrFile <> ThisDocument.Name And (Right(CurrFile, 5) = ".docx" Or Right(CurrFile, 4) = ".doc") Then
                tempFileName = sourceFilePath & CurrFile
                Set currDoc = Documents.Open(tempFileName, Visible:=False)
                ' 找到关键字的,另存一份到 newPath 下
                If 对关键字打标记(currDoc, ThisDocument) Then
                    currDoc.SaveAs2 FileName:=newPath & CurrFile, FileFormat:=wdFormatXMLDocument
                    Kill tempFileName
                    currDoc.Close wdDoNotSaveChanges
                    Set currDoc = Nothing
                    'DoEvents
                Else
                    currDoc.Close wdDoNotSaveChanges
                    Set currDoc = Nothing
                    skiplog tempFileName
                    Call moveFile(tempFileName, skipPath & CurrFile)
                End If    
            End If
    NextFile:
            CurrFile = Dir()
        Loop
        
        Set fs = Nothing
        Call MsgBox("处理完毕", vbOKOnly + vbInformation, "温馨提示")
    Exit Sub
    ErrorHandler:
        errlog "================================================================================"
        errlog "【错误文件】" & tempFileName
        errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
        Call moveFile(tempFileName, errPath & CurrFile)
        Resume NextFile
    End Sub
    

    写日志

    ' 写日志
    Sub errlog(logMsg As String)
        Shell "cmd.exe /c echo " & Format(Now, "YYYY-MM-DD HH:MM:SS") & " ===》 " & logMsg & " >> " & errLogFile
    End Sub
    
    Sub skiplog(logMsg As String)
        Shell "cmd.exe /c echo " & logMsg & " >> " & skipLogFile
    End Sub
    

    移动文件

    ' 移动文件
    Sub moveFile(sourcePath As String, targetPath As String)
        On Error GoTo ErrorHandler
        Call fs.moveFile(sourcePath, targetPath)
    Error_Handler_Exit:
        Exit Sub
    Exit Sub
    ErrorHandler:
        errlog "================================================================================"
        errlog "【移动文件失败】" & sourcePath
        errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
    Resume Error_Handler_Exit
    End Sub
    

    选择目录

    Function SelectFolder()
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ThisDocument.path & "\"
            If .Show = -1 Then ' OK返回 -1,Cancel 返回 0
                sourceFilePath = .SelectedItems(1) & "\"
                SelectFolder = True
            Else
                SelectFolder = False
            End If
        End With
    End Function
    

    对关键字打标记(查找替换)

    注意:如果是 .Execute Replace:=wdReplaceOne (替换第一个), 那么 With doc.Content.Find 就要放到循环里面了。否则会出现意外的丢失情况! :比如:ABA先搜B,再搜A,替换的不是第一个A用是第二个A。未细研究根源,仅此备注。

    Function 对关键字打标记(doc As Document, MainDoc As Document)
        Dim i As Integer, keyArrLen As Integer, keyArray() As String, styleName As String, edited As Boolean
        
        edited = False ' 默认未编辑状态
        keyArray = 获取关键字(MainDoc)
        keyArrLen = UBound(keyArray)
        styleName = 创建样式(doc)
       
        With doc.Content.Find
           .ClearFormatting
           .Replacement.ClearFormatting
           .Replacement.style = styleName
           .Replacement.Text = "^&"
           .Forward = True
           .Wrap = wdFindContinue
           ' 遍历查找关键字,并标示
            For i = 0 To keyArrLen
                .Text = keyArray(i)
                .Execute Replace:=wdReplaceAll
                ' 找到了关键字,标记为编辑过。
                If .Found Then
                    edited = True
                End If
            Next
        End With
        
        对关键字打标记 = edited
    End Function
    

    创建样式

    Function 创建样式(doc As Document)
        On Error Resume Next ' 出错时忽略,继续向下运行。
        ' 判断样式,不存在则创建
        Dim flag As Boolean, syte As style, styleName As String
        styleName = "关键字"
        
        flag = True
        For Each syte In doc.Styles
            If syte.NameLocal = styleName Then
                flag = False
            End If
        Next
        
        If flag Then
            doc.Styles.Add Name:=styleName, Type:=wdStyleTypeCharacter
            With doc.Styles(styleName).Font
                .NameFarEast = "微软雅黑"
                .Bold = True
                .Color = wdColorYellow
                .Shading.ForegroundPatternColor = wdColorAutomatic
                .Shading.BackgroundPatternColor = wdColorRed
            End With
        End If
        
        创建样式 = styleName
    End Function
    

    获取关键字(动态数组)

    Function 获取关键字(doc As Document)
        Dim keyArray() As String, arrLen As Integer, pgs As Paragraphs, i As Integer
        ' 取当前文档所有段落
        Set pgs = doc.Paragraphs
        arrLen = pgs.Count - 1
        ' 重置动态数组的长度
        ReDim keyArray(arrLen) As String
    
        ' 遍历段落,将文字加入数组
        For i = 0 To arrLen
            keyArray(i) = Replace(Trim(pgs(i + 1).Range.Text), vbCr, "")
        Next
    
        获取关键字 = keyArray
    End Function
    

    参考资料

    湖边的小屋圣迹 - Excel、Word VBA 学习笔记
    w3cschool.cn VBA操作文件和文件夹步骤
    VBA 收集 Word关键字批量处理-Excel版(升级版)

    更多相关内容
  • 这不是源代码,是通过C#在VS2010下实现的,可以说是个小工具,实现的功能是:打开某一文件下的所有word文档,然后设置一个或多个关键字,然后查找这些关键字是否在word中出现,并将word文档名和关键字保存在excel的...
  • 利用win7自带的搜索功能 点开某一个文件夹下面-组织-文件夹和搜索选项 进入文件夹和搜索选项后,选择搜索,勾选如下图所示例 即可在文件右上方搜索要找的关键字

    利用win7自带的搜索功能

    点开某一个文件夹下面-组织-文件夹和搜索选项

    进入文件夹和搜索选项后,选择搜索,勾选如下图所示例

    即可在文件右上方搜索要找的关键字 。

    展开全文
  • 快速在多个word文件里面检索到关键字 标签: windows 之前看论文做了很多笔记,直接用word写的笔记。 然后,今天忽然需要过去做的一个笔记,但是只知道里面关键字xx。 所以看着我那一年的笔记量,我陷入的沉思,我...

    快速在多个word文件里面检索到关键字

    标签: windows


    之前看论文做了很多笔记,直接用word写的笔记。

    然后,今天忽然需要过去做的一个笔记,但是只知道里面关键字xx

    所以看着我那一年的笔记量,我陷入的沉思,我肯定不能一个个打开搜索呀,那估计要搞一段时间,后来我就后悔没有直接写在有道云笔记上,这样就能直接搜索了。

    后来发现windows的搜索原来这么强,还能够搜索内容:

    2019-10-24_213802.jpg

    只要在搜索框中加入内容:即可。

    除此之外,也可以通过软件XSearch进行搜索,我测试了一下,结果也不错。下载链接 https://en.softonic.com/download/xsearch/windows/post-download

    既然谈到了搜索,就再推荐两个搜索的软件,第一个是EveryThing,这个软件比win自带的龟速软件快的多,可以自行搜索下载,Listary 类似于Everything的一个软件,DocFetcher同样能够按内容搜索的软件。

    展开全文
  • VBA 收集 Word关键字批量处理-Excel版Sheet1(关键字)ThisWorkbookUserForm1模块1 Sheet1(关键字) 表格中添加了一个按钮,用于打开窗口 Private Sub CommandButton1_Click() UserForm1.Show End Sub ThisWorkbook ...

    预览图-内涵图

    copy /b 图片.gif /b + 压缩包.zip /b 结果图片.gif
    

    Word关键字批量处理-v0.1 Word关键字批量处理-v0.2
    Word关键字批量处理-20220321-v1

    • 20220321
      1 修复遍历多级目录时生成文件放错位置的BUG。
      2 优化开始按钮,改为切换开始暂停(其实就是结束,再次开始,可以继续处理,只有实时日志会清空重新开始打印)。
      3 优化性能,没2000个文档,重启一次Word。(切记要隐藏运行,如果显示界面,未和谐的授权窗口会卡住需要手点跳过)虽然这么做个,但是暂时还不知道变慢的原因,内存CPU都显示正常。

    UserForm1(窗体代码)

    窗体逻辑主要是:

    1. 窗体内容初始化。
    2. 控件事件处理。
    Private Sub UserForm_Initialize()
        Dim currPath$, currName$
        currPath = ThisWorkbook.path & "\"
        currName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)
        
        源文件的目录TextBox.Text = currPath & SOURCE_FILE_PATH
        完成文件的目录TextBox.Text = currPath & FINISHED_FILE_PATH
        失败文件的目录TextBox.Text = currPath & ERROR_FILE_PATH
        跳过文件的目录TextBox.Text = currPath & SKIP_FILE_PATH
        
        成功日志TextBox.Text = currPath & currName & SUCCESS_FILE_SUFFIX
        失败日志TextBox.Text = currPath & currName & ERROR_FILE_SUFFIX
        跳过日志TextBox.Text = currPath & currName & SKIP_FILE_SUFFIX
    
        successLogFile = 成功日志TextBox.Text
        errLogFile = 失败日志TextBox.Text
        skipLogFile = 跳过日志TextBox.Text
        
        Set myConsole = 日志窗口TextBox
        showDoc = 处理时显示文档CheckBox.Value
        
        With Me.WebBrowser1
            .Navigate "about:blank"
            .Document.Write "<body scroll='no' style='margin: 0;border = 0;'><img id='img' src='https://img-blog.csdnimg.cn/00f4705c12f34cdc99636aedf2fe1f1e.gif' style='width: 100%;height:100%;'></body>"
        End With
    
        子目录深度ScrollBar.Min = 0
        
        日志窗口TextBox.Text = "日志窗口:" & vbCrLf & vbCrLf & "           笑    虾" & vbCrLf & "天上游龙水中蛟,不羡高飞入云霄。" & vbCrLf & "生来无事终天笑,未曾到老先弯腰。" & vbCrLf & vbCrLf
        
    End Sub
    
    Private Sub UserForm_Activate()
    '    Call 刷新目录结构(源文件的目录TextBox.Text, 0)
    '    子目录深度ScrollBar.Max = subFolderMaxLeve
        子目录深度ScrollBar.Value = 0
    End Sub
    
    Private Sub 获取源文件目录Button_Click()
        Dim path$, arr() As String
        源文件的目录TextBox.Text = 选择目录()
        Call 刷新目录结构(源文件的目录TextBox.Text, 子目录深度ScrollBar.Value)
    End Sub
    
    Private Sub 成功日志TextBox_Change()
        successLogFile = 成功日志TextBox.Text
    End Sub
    
    Private Sub 失败日志TextBox_Change()
        errLogFile = 失败日志TextBox.Text
    End Sub
    
    Private Sub 跳过日志TextBox_Change()
        skipLogFile = 跳过日志TextBox.Text
    End Sub
    
    Private Sub 子目录深度ScrollBar_Change()
        子目录深度TextBox.Value = 子目录深度ScrollBar.Value
        Call 刷新目录结构(源文件的目录TextBox.Text, 子目录深度ScrollBar.Value)
    End Sub
    
    Private Sub 处理时显示文档CheckBox_Change()
    On Error Resume Next
        showDoc = 处理时显示文档CheckBox.Value
        wordApp.Visible = showDoc
    End Sub
    
    Private Sub start()
        ' 选择要处理的文件所在
        If 源文件的目录TextBox.Text = "" Then
            源文件的目录TextBox.Text = 选择目录()
        End If
        If MsgBox("要处理的文件在:" & 源文件的目录TextBox.Text, vbYesNo + vbInformation, "确认源文件目录") <> vbYes Then
            开始暂停ToggleButton.Caption = "开 始"
            开始暂停ToggleButton.Value = False
            Exit Sub
        End If
        
        Call 遍历文件夹中对文档的关键字打标记(源文件的目录TextBox.Text, 完成文件的目录TextBox.Text, 失败文件的目录TextBox.Text, 跳过文件的目录TextBox.Text, 日志窗口TextBox)
    End Sub
    
    Private Sub 开始暂停ToggleButton_Click()
        If 开始暂停ToggleButton.Value Then
            开始暂停ToggleButton.Caption = "暂 停"
            Debug.Print 开始暂停ToggleButton.Value & "暂 停"
            Call start
        Else
            开始暂停ToggleButton.Caption = "开 始"
            Debug.Print 开始暂停ToggleButton.Value & "开 始"
        End If
        
    End Sub
    
    Private Sub csdn博客Label_Click()
        Shell "cmd /c start https://jerryjin.blog.csdn.net/article/details/123596090", vbHide
    End Sub
    
    Private Sub 刷新目录结构(目标文件夹 As String, subLevel As Integer)
        
        Call 更新文件夹结构信息(目标文件夹, subLevel)
        
        子目录深度ScrollBar.Max = subFolderMaxLeve
        
        infoLog ("======================获取目录结构成功======================")
        Call infoLog(subFolderString, "", "", "", vbCrLf)
    
        
    End Sub
    
    
    
    

    业务逻辑

    遍历文档,查找替换的业务逻辑都在这。

    1. 遍历文件使用了vbaDir("目标文件夹")方法。第一次目录参数,第二次不带参,就可以逐个返回下一文件,直到返回空字符串结束。
    2. 移动文件使用了:Scripting.FileSystemObject
    3. 输出日志文件用的是 VBAShell "cmd.exe /c echo 日志内容 >> 日志文件", vbHide,第二个参数vbHide表示隐藏执行。
    Option Explicit
    
    Public Const SOURCE_FILE_PATH As String = "sourceData\"        ' 要处理的文件所在
    Public Const FINISHED_FILE_PATH As String = "newData\"         ' 存完成文件的目录名
    Public Const ERROR_FILE_PATH As String = "errorData\"          ' 存出错文件的目录名
    Public Const SKIP_FILE_PATH As String = "skipData\"            ' 存跳过文件的目录名
    Public Const DELIMS As String = ","                            ' 关键字分隔符
    Public Const DEFULT_REPLACEMENT_TEXT As String = "^&"          ' 默认替换字符
    Public Const STYLE_NAME As String = "关键字"                   ' 样式名
    Public Const DEL_FLAG As String = "【del】"                    ' 获取所有文件夹时使用的过滤删除标记。
    
    Public Const ERROR_FILE_SUFFIX As String = "-Err.log"          ' 出错日志后缀
    Public Const SKIP_FILE_SUFFIX As String = "-Skip.log"          ' 跳过日志后缀
    Public Const SUCCESS_FILE_SUFFIX As String = "-Success.log"    ' 跳过日志后缀
    
    Public successLogFile As String                                ' 成功日志
    Public errLogFile As String                                    ' 错误日志
    Public skipLogFile As String                                   ' 跳过记录的日志
     
    Public myConsole As Object                                     ' 跳过记录的日志
    Public showDoc As Boolean                                      ' 显示word
    
    Public subFolderArr() As String                                ' 需要遍历的目录结构
    Public subFolderRelativePathArr() As String                    ' 需要目录结构相对路径(以原文件目录为基准)
    Public subFolderMaxLeve As Integer                             ' 需要遍历的目录结构最大深度
    Public subFolderString As String                               ' 需要遍历的目录结构(字符串)
    
    Public fs As Object                                            ' 文件系统对象
    Public wordApp As Word.Application                             ' word 对象
    
    Private keyArray() As String                                   ' 需要处理的关键字,载入此数组
    Private keyArrLen As Integer                                   ' 需要处理的关键字个数
     
    Sub 遍历文件夹中对文档的关键字打标记(sourceFilePath As String, newPath As String, errPath As String, skipPath As String, logTextBox As Object)
        On Error GoTo ErrorHandler
         'currPath$,
        Dim CurrFile$, CurrFileName$, currDoc As Word.Document, tempFileName As String, pathLen As Integer, path_i As Integer
        
        ' --------- 初始化 开始 ----------
        ' 准备 word 对象
        Call clearLog
        Call infoLog("1. 初始化 word 对象……")
        Set wordApp = 获取wordApp实例()
        wordApp.Visible = showDoc
        Call infoLog("2. 初始化 word 对象完成!^_^")
        ' 获取个当前位置信息
    '    currPath = ThisWorkbook.path & "\"
        CurrFileName = ThisWorkbook.Name
        Call infoLog("3. 定位当前文档位置成功!")
        ' 创建文件系统对象
        Set fs = CreateObject("Scripting.FileSystemObject")
        Call infoLog("4. 获取 FileSystemObject 成功!")
        ' 准备文件夹:复制文件夹结构
        If Dir(newPath, vbDirectory) = vbNullString Then Call 复制文件夹结构(sourceFilePath, newPath) 'MkDir newPath
        Call infoLog("5. 成功文件目录准备完毕!")
        If Dir(skipPath, vbDirectory) = vbNullString Then Call 复制文件夹结构(sourceFilePath, skipPath) 'MkDir skipPath
        Call infoLog("6. 跳过文件目录准备完毕!")
        If Dir(errPath, vbDirectory) = vbNullString Then Call 复制文件夹结构(sourceFilePath, errPath) ' MkDir errPath
        Call infoLog("7. 失败文件目录准备完毕!")
        ' 从excel表读取取关键字
        keyArray = 获取关键字()
        keyArrLen = UBound(keyArray)
        Call infoLog("8. 加载关键字数据完成!")
        ' --------- 初始化 结束 ----------
        
        Call infoLog("9. 开始处理文档……")
        UserForm1.WebBrowser1.Visible = True
    
        ' -------------------------- 遍历目录 开始 --------------------------
        Dim tempNewPath$, tempSkipPath$, tempErrPath$
        pathLen = UBound(subFolderArr)
        For path_i = 0 To pathLen
            ' 获取当前目录的成功失败跳过等相关路径
            sourceFilePath = subFolderArr(path_i)
            tempNewPath = newPath & subFolderRelativePathArr(path_i)
            tempSkipPath = skipPath & subFolderRelativePathArr(path_i)
            tempErrPath = errPath & subFolderRelativePathArr(path_i)
            Call infoLog(sourceFilePath, "【开始处理文件夹】:", "", "", vbCrLf)
            
            CurrFile = Dir(sourceFilePath)
            ' ------------- 遍历目录中的文件 开始 -------------
            Do Until CurrFile = ""
                If Right(CurrFile, 5) = ".docx" Or Right(CurrFile, 4) = ".doc" Then
                    tempFileName = sourceFilePath & CurrFile
             
                    Set currDoc = wordApp.Documents.Open(tempFileName, Visible:=showDoc)
        '            Debug.Print currDoc.Content
                    
                    ' 找到关键字的,另存一份到 newPath 下
                    If 对关键字打标记(currDoc) Then
                        currDoc.SaveAs2 Filename:=tempNewPath & CurrFile, FileFormat:=wdFormatXMLDocument
                        Kill tempFileName
                        currDoc.Close wdDoNotSaveChanges
                        Set currDoc = Nothing
                        successlog tempFileName
                        UserForm1.成功数量TextBox.Value = UserForm1.成功数量TextBox.Value + 1
                    Else
                        currDoc.Close wdDoNotSaveChanges
                        Set currDoc = Nothing
                        skiplog tempFileName
                        Call 移动文件(tempFileName, tempSkipPath & CurrFile)
                        UserForm1.跳过数量TextBox.Value = UserForm1.跳过数量TextBox.Value + 1
                    End If
    
                End If
    NextFile:
                DoEvents
                ' 如果按下暂停按钮
                If UserForm1.开始暂停ToggleButton.Value = False Then
                    Call infoLog("暂停中。。。。。。")
                    wordApp.Quit    ' 关闭 word
                    Exit Sub
                End If
                ' 优化性能 每2000次重启一下word
                If (0 + UserForm1.成功数量TextBox.Value + UserForm1.跳过数量TextBox.Value + UserForm1.失败数量TextBox.Value) Mod 2000 = 0 Then
                    Call infoLog("优化性能:Word 重启中。。。。。。")
                    wordApp.Quit    ' 关闭 word
                    Set wordApp = Nothing
                    Set wordApp = CreateObject("Word.Application")
                    wordApp.Visible = showDoc
                End If
                CurrFile = Dir()
    
            Loop
            ' ------------- 遍历目录中的文件 结束 -------------
        Next
        ' -------------------------- 遍历目录 结束 --------------------------
        Set fs = Nothing
        ' 处理完毕重置UI
        wordApp.Visible = True
        UserForm1.WebBrowser1.Visible = False
        UserForm1.处理时显示文档CheckBox.Value = True
        UserForm1.开始暂停ToggleButton.Caption = "开 始"
        UserForm1.开始暂停ToggleButton.Value = False
        'wordApp.Quit    ' 关闭 word
        Call MsgBox("处理完毕,共处理 " & (0 + UserForm1.成功数量TextBox.Value + UserForm1.跳过数量TextBox.Value + UserForm1.失败数量TextBox.Value) & "个文档!", vbOKOnly + vbInformation, "温馨提示")
        
    Exit Sub
    ErrorHandler:
        UserForm1.失败数量TextBox.Value = UserForm1.失败数量TextBox.Value + 1
        errlog "================================================================================"
        errlog "【错误文件】" & tempFileName
        errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
        Call 移动文件(tempFileName, tempErrPath & CurrFile)
        Resume NextFile
    End Sub
    
    Function 对关键字打标记(doc As Word.Document)
    On Error GoTo ErrorHandler
        Dim i As Integer, edited As Boolean ' 默认未编辑状态false
    
        Call 创建样式(doc, STYLE_NAME)
        
      ' 遍历查找关键字,并标示。    keyArray = [0源字符, 1目标字符, 2替换方式, 3高亮]
        For i = 0 To keyArrLen
        
            With doc.Content.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Forward = True
                .Wrap = wdFindContinue
                .Text = keyArray(i, 0)
                .Replacement.Text = keyArray(i, 1)
                    
                If keyArray(i, 3) = "是" Then
                    .Replacement.Style = STYLE_NAME
                Else
                    .Replacement.ClearFormatting
                End If
                
                Call .Execute(Replace:=keyArray(i, 2))
    NextKey:
                ' 找到了关键字,标记为编辑过。
                If .Found Then edited = True
                
            End With
            DoEvents
        Next
    
        对关键字打标记 = edited
        
    Exit Function
    ErrorHandler:
        errlog "================================================================================"
        errlog "【对关键字打标记出错】" & keyArray(i, 0)
        errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
        Resume NextKey
    End Function
    
    Function 创建样式(doc As Word.Document, styleName As String)
    On Error Resume Next ' 出错时忽略,继续向下运行。
    
        ' 判断样式,不存在则创建
        Dim flag As Boolean
        flag = doc.Styles(styleName).NameLocal = styleName
        If flag Then
            Exit Function
        End If
        
        doc.Styles.Add Name:=styleName, Type:=wdStyleTypeCharacter
        With doc.Styles(styleName).Font
    '        .NameFarEast = "微软雅黑"
            .Bold = True
            .Color = wdColorYellow
            .Shading.ForegroundPatternColor = wdColorAutomatic
            .Shading.BackgroundPatternColor = wdColorRed
        End With
         
    End Function
    
    ' keyArray = [0源字符, 1目标字符, 2替换方式, 3高亮]
    Function 获取关键字() As String()
        Dim myRanges As Range, keyArray() As String, arrLen As Integer, i As Integer, j As Integer, dict As Object
    
        ' 字段名与列号对应存入字典
        Set dict = CreateObject("Scripting.Dictionary")
        Call dict.Add("源字符", Range("b1:e1").Find("源字符").Column - 1)
        Call dict.Add("目标字符", Range("b1:e1").Find("目标字符").Column - 1)
        Call dict.Add("替换方式", Range("b1:e1").Find("替换方式").Column - 1)
        Call dict.Add("高亮", Range("b1:e1").Find("高亮").Column - 1)
    
        ' 数据行数
        arrLen = Range(Range("B2"), Range("B2").End(xlDown)).Rows.Count
        
        ' 数据范围
        Set myRanges = Worksheets("关键字").Range(Range("B2"), Range("E2").Offset(arrLen - 1, 0))
        
        ' 重置动态数组的长度
        ReDim keyArray(arrLen - 1, 3) As String
        
        For i = 0 To arrLen - 1
            keyArray(i, 0) = myRanges(i + 1, dict.Item("源字符"))
            keyArray(i, 1) = myRanges(i + 1, dict.Item("目标字符"))
            If myRanges(i + 1, dict.Item("替换方式")) = "首个" Then
                keyArray(i, 2) = 1  ' wdReplaceOne  替换遇到的第一个匹配项。
            Else
                keyArray(i, 2) = 2  ' wdReplaceAll   替换所有匹配项。
            End If
            keyArray(i, 3) = "是"
        Next i
    
        获取关键字 = keyArray
    End Function
    
    ' 移动文件
    Sub 移动文件(sourcePath As String, targetPath As String)
    On Error GoTo ErrorHandler
        Call fs.moveFile(sourcePath, targetPath)
    Error_Handler_Exit:
        Exit Sub
    ErrorHandler:
        errlog "================================================================================"
        errlog "【移动文件失败】" & sourcePath
        errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
        Resume Error_Handler_Exit
    End Sub
    
    ' 获取word应用,失败就创建一个新的
    Function 获取wordApp实例()
    On Error Resume Next
        Set 获取wordApp实例 = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
        Set 获取wordApp实例 = CreateObject("Word.Application")
        End If
    End Function
    
    ' 写日志
    Sub errlog(logMsg As String)
        Shell "cmd.exe /c echo " & Format(Now, "YYYY-MM-DD HH:MM:SS") & " 》" & logMsg & " >> " & errLogFile, vbHide
        Call infoLog(logMsg, "【失败】:")
    End Sub
    Sub skiplog(logMsg As String)
        Shell "cmd.exe /c echo " & logMsg & " >> " & skipLogFile, vbHide
        Call infoLog(logMsg, "【跳过】:")
    End Sub
    Sub successlog(logMsg As String)
        Shell "cmd.exe /c echo " & logMsg & " >> " & successLogFile, vbHide
        Call infoLog(logMsg, "【成功】:")
    End Sub
    Sub infoLog(logMsg As String, Optional logType As String = "【信息】:", Optional logTime As String = "now", Optional logSeparator As String = " ===》 ", Optional logEnd As String = "")
        myConsole.Text = myConsole
        With myConsole
            .SetFocus
            .Text = .Text & vbCrLf & logType & VBA.IIf(logTime = "now", Format(Now, "YYYY-MM-DD HH:MM:SS"), logTime) & logSeparator & logMsg & logEnd
            .SelStart = Len(.Value)
        End With
        DoEvents
    End Sub
    Sub clearLog()
        myConsole.Text = ""
    End Sub
    
    
    

    工具模块

    1. 遍历文件夹,看了网上的方案感觉效率不太给力,这里直接调CMD命令曲线救国了。dir C:\原目录 /b/s *.doc?
    2. 批量拷贝目录结构,不带文件。xcopy C:\原目录 C:\目标目录 /t/i
    Function 选择目录()
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = ThisWorkbook.path & "\"
            If .Show = -1 Then ' OK返回 -1,Cancel 返回 0
                选择目录 = .SelectedItems(1)
            Else
                选择目录 = ""
            End If
        End With
    End Function
    
    Function 统计字符串出现次数(sourceStr As String, searchStr As String) As Long
    On Error GoTo Error_Handler
        统计字符串出现次数 = UBound(Split(sourceStr, searchStr))
    Error_Handler_Exit:
        Exit Function
    Error_Handler:
        Resume Error_Handler_Exit
    End Function
    
    Function 执行cmd命令(cmdStr As String) As String
    On Error Resume Next
        Dim oShell As Object                                        ' WScript.Shell
        Dim oExec As Object                                         ' WScript.Shell的Exec执行结果对象
    
        Set oShell = CreateObject("WScript.Shell")
        Set oExec = oShell.Exec("cmd /c " & cmdStr)
        
        执行cmd命令 = oExec.StdOut.ReadAll
        
        oShell.Quit
        Set oExec = Nothing
        Set oShell = Nothing
    End Function
    
    ' 刷新【子文件夹结构数组】【子文件夹最大深度】【子文件夹结构字符串】
    Function 更新文件夹结构信息(目标文件夹 As String, depth As Integer) As String
    On Error Resume Next
        Dim arr() As String, arrLen As Integer, baseDepth As String, i As Integer, currDepth As Integer, str As String
        ' 末尾有 \ 就去掉
        目标文件夹 = VBA.IIf(Right(目标文件夹, 1) = "\", Left(目标文件夹, Len(目标文件夹) - 1), 目标文件夹)
        ' 目标文件夹作为基础深度
        baseDepth = 统计字符串出现次数(目标文件夹, "\")
        ' 执行cmd命令获取所有子文件夹
        str = 目标文件夹 & vbCrLf & 执行cmd命令("dir " & 目标文件夹 & " /ad /s /b")
        ' 按 vbCrLf 切分为数组
        arr = Split(str, vbCrLf)
        
        arrLen = UBound(arr)
        ' 遍历所有目录
        For i = 0 To arrLen
            currDepth = 统计字符串出现次数(arr(i), "\") - baseDepth
            
            If Len(arr(i)) = 0 Or currDepth > depth Then
                arr(i) = DEL_FLAG
            Else
                arr(i) = VBA.IIf(Right(arr(i), 1) <> "\", arr(i) & "\", arr(i))
            End If
            ' 更新子文件夹最大深度
            subFolderMaxLeve = VBA.IIf(currDepth > subFolderMaxLeve, currDepth, subFolderMaxLeve)
        Next
        
        ' 过滤掉空字符串,得到结果
        arr = Filter(arr, DEL_FLAG, False, vbTextCompare)
        
        ' 更新子文件夹结构数组
        subFolderArr = arr
        ' 更新子文件夹结构字符串
        subFolderString = Join(subFolderArr, vbCrLf)
        
        ' 获取相对文件
        subFolderRelativePathArr = Split(Replace(subFolderString, 目标文件夹 & "\", ""), vbCrLf)
        
        更新文件夹结构信息 = subFolderString
    End Function
    
    Function 复制文件夹结构(原文件夹 As String, 目标文件夹 As String)
        Call 执行cmd命令("xcopy " & 原文件夹 & " " & 目标文件夹 & " /t/i")
    End Function
    
    Function 移除末尾空行(myString As String)
        If Len(myString) > 0 Then
            If Right$(myString, 2) = vbCrLf Or Right$(myString, 2) = vbNewLine Then
                myString = Left$(myString, Len(myString) - 2)
            End If
        End If
        移除末尾空行 = myString
    End Function
    
    

    性能优化

    暂时感觉不出来。。。目前越来越慢的是word,但是又好像有当前这个Excel有关系。

    Public CalcState As Long
    Public EventState As Boolean
    Public PageBreakState As Boolean
    ' 业务代码开始前执行
    Sub OptimizeCode_Begin(app As Object)
    On Error Resume Next
        app.ScreenUpdating = False
        EventState = app.EnableEvents
        app.EnableEvents = False
        CalcState = app.Calculation
        app.Calculation = xlCalculationManual
        PageBreakState = ActiveSheet.DisplayPageBreaks
        ActiveSheet.DisplayPageBreaks = False
    End Sub
    ' 业务代码结束后执行
    Sub OptimizeCode_End(app As Object)
    On Error Resume Next
        ActiveSheet.DisplayPageBreaks = PageBreakState
        app.Calculation = CalcState
        app.EnableEvents = EventState
        app.ScreenUpdating = True
    End Sub
    

    Sheet1(关键字)(工作表按钮事件)

    表格中添加了一个按钮,用于打开窗口

    Private Sub CommandButton1_Click()
        UserForm1.Show
    End Sub
    

    ThisWorkbook(工作簿事件)

    打开工作簿后自动弹出窗口

    Private Sub Workbook_Activate()
        UserForm1.Show
    End Sub
    

    引用 word

    因为声明了word对象,需要引用一下库。
    在这里插入图片描述

    源文件

    下载↑↑↑顶部预览图,用解压工具打开即可。
    在这里插入图片描述

    参考资料

    How to fit image size on excel WebBrowser control
    Word实现的那个旧版 —— VBA 收集 Word关键字批量处理

    展开全文
  • Python根据关键字抓取word相关内容

    千次阅读 2021-01-14 20:00:57
    用python我们可以抓取网页,表格,JSON这种半结构化的数据,那么word文档中的内容这种非结构化的数据我们如何抓取呢。今天我来教大家如何实现python对docx类型的文档中数据的读取,并根据关键字提取相应的内容,然后...
  • public static List<String> getWordKey(String templateUri) { String buffer = ""; List<String> keyListFromString = null;... // 添加返回数据中 allStringList.add(temp); } } } return allStringList; }
  • Python查找包含指定字符串的所有Office文档 Python查找包含指定字符串的所有文件 Python提取Word文档中所有超链接地址和文本 Python课程期末考试编程题自动批卷原理与实现模板 使用Python批量提取并保存docx文档中的...
  • 查找及使用步骤:1、打开一个需要排序的Word文档。2、在页面上方的工具栏中找到下图做红色标注的排序图标。3、点击排序图标后,进入排序文字的界面,可以根据需要选择排序方式。4、设置好排序方式后,点击确定即可...
  • 怎么在一个文件夹内搜索word文章内的关键字? 我想在一个文件夹里搜索里面word文档的内容,怎么弄呢? https://zhidao.baidu.com/question/557700531.html
  • 2、将查找到的字符全部选中,然后复制。 解决方案: 问题1解决方案: 在Word的高级查找中,点中“使用通配符”,然后在查找框中输入例如:\ [*\ ] PS: ① [ 和 ]:代表查找“[”和“]”两个符号的本身 ② :代表...
  • 越来越多的办公系统中的Word文档都采用了SOAOffice中间件来在线打开保存,同时也产生了一些更好、更高级的需求,本文所讨论的正是这样的一个需求: 打开文档的时候,高亮显示指定的关键字。 搜索结果高亮...
  • 具体的工作需求:在指定的Word文档(*.doc文件/*.docx文件)中查找关键字,找到后做高亮操作或者直接删除操作,然后另存为别的目录(表示这个文件被操作过了)。 这个功能很简单,确实挺简单,但由于是第一次用...
  • 使用solr 检索word文档

    千次阅读 2019-06-27 10:06:02
    通过/update表示更新索引,<strong>Solr默认根据id(唯一约束)域来更新Document的内容,如果根据id值搜索不到id域则会执行添加操作,如果找到则更新。 通过此菜单可以创建索引、更新索引、删除索引等操作。 <p>...
  • 这里介绍的需要批量修改和删除文档中的关键字关键词的场景是:我们有大量的 Word 文件,这些文件中的一部分需要批量修改为某个关键字,另一个部分的 Word 文件需要批量删除某个关键字,这里的关键字有多个,且并...
  • 先来说查找,方便我们快速找到想要的内容,输入快捷键ctrl+f即可调出操作面板,操作面板会出现在文档左边,点击下拉菜单,可以看到可以查找的内容有图形、表格、公式、脚注/尾注、批注,如果...
  • 开发过程中会遇到很多给一个模板上赋值的任务,一般都是使用占位符等操作,对需要赋值的位置进行文本赋值,还有一种是找到关键字,然后获取其在文档中的位置,然后进行坐标偏移赋值。今天就来介绍第二种方式。 开始...
  • Java根据关键字在PDF/Word插入图片

    千次阅读 2022-01-28 11:51:03
    在pdf/word中,根据定义的关键字标识,进行插入图片
  • 1、该工具可以在指定文件夹下所有Word、Excel和文本文档中批量查找指定关键字(也可同时指定多个关键字)。第一次搜索速度会稍慢,但是该软件会对查找过的文件建立索引,再次搜索时速度成倍提升! 2、该工具支持...
  • 对多个WORD文档执行替换,包含正文、页眉和页脚。同时还支持多个关键字替换,例如将1替换成A,将2替换成B,将3替换成C...... 段落缩进 让指定的段落首行缩进俩字符。 中英互译 对选区的字符执行中译英、英译中操作.....
  • 今天给大家带来的这款专门针对 Word、PPT、Excel、PDF 和记事本文本文件批量处理格式转换的软件——我的ABC软件工具箱。它集合了批量修改文件名称、批量修改文件内容、批量设置页眉页脚、批量格式转换、批量水印设置...
  • 电脑word搜索工具

    2021-07-27 02:08:05
    如何查找word程序在电脑的什么位置搜索word文档里的内容,步骤如下:1打开需要查看的word文档:2点击右上角箭头所指的查找。3在左侧箭头所示处填写需要查找的内容。4查找完成。扩展资料:word替换文档中所有的关键字...
  • 需求场景开发的web办公系统如果需要处理大量的Word文档(比如有成千上万个文档),用户一定提出查找包含某些关键字的文档的需求,这就要求能够读取 word 中的文字内容,而忽略其中的文字样式、表格、图片等信息。...
  • 该工具可以在指定文件夹下所有Word、Excel和TXT文档中批量查找指定关键字(也可同时指定多个关键字),第一次搜索速度稍慢,但是该工具会对查找过的文件建立索引,再次搜索速度极快。 该工具支持2007版本以上的文档...
  • jacob替换word关键字

    千次阅读 2012-03-16 16:36:49
    * word文档 */ private Dispatch doc = null; /** * word运行程序对象 */ private ActiveXComponent word; /** * 所有word文档 */ private Dispatch documents; ...
  • 1、该工具可以在指定文件夹下所有Word、Excel、PowerPoint、PDF和文本文档中批量查找指定关键字(也可同时指定多个关键字)。第一次搜索速度会稍慢,但是该软件会对查找过的文件建立索引,再次搜索时速度成倍提升! ...
  • 纯前端导出word文档

    千次阅读 2019-09-29 12:07:05
    实现这个功能时参考了两处文档,但是都有兼容性问题一个是兼容ie,一个是只能在ie中使用,不过正好互补了,下面是结合两处文档之后的。(摘自想要飞翔的小猪和iteye_10362的博客。) 注意:ActiveXObject是ie特有的...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 25,296
精华内容 10,118
关键字:

word文档查找不到关键字