當前位置：首頁 > 编程资源 > 编程问答 >内容正文

编程问答

VBA 收集 Word关键字批量处理-Excel版

發布時間：2023/12/10 编程问答 46 豆豆

生活随笔收集整理的這篇文章主要介紹了 VBA 收集 Word关键字批量处理-Excel版小編覺得挺不錯的,現在分享給大家,幫大家做個參考.

VBA 收集 Word關鍵字批量處理-Excel版

UserForm1（窗體代碼）
業務邏輯
工具模塊
性能優化
Sheet1(關鍵字)（工作表按鈕事件）
ThisWorkbook（工作簿事件）
引用 word
源文件
參考資料

預覽圖-內涵圖

copy /b 圖片.gif /b + 壓縮包.zip /b 結果圖片.gif

20220321
1 修復遍歷多級目錄時生成文件放錯位置的BUG。
2 優化開始按鈕，改為切換開始暫停（其實就是結束，再次開始，可以繼續處理，只有實時日志會清空重新開始打印）。
3 優化性能，沒2000個文檔，重啟一次Word。（切記要隱藏運行，如果顯示界面，未和諧的授權窗口會卡住需要手點跳過）雖然這么做個，但是暫時還不知道變慢的原因，內存CPU都顯示正常。

UserForm1（窗體代碼）

窗體邏輯主要是：

窗體內容初始化。

控件事件處理。

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_SUFFIXsuccessLogFile = 成功日志TextBox.TexterrLogFile = 失敗日志TextBox.TextskipLogFile = 跳過日志TextBox.TextSet myConsole = 日志窗口TextBoxshowDoc = 處理時顯示文檔CheckBox.ValueWith 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 & vbCrLfEnd SubPrivate Sub UserForm_Activate() ' Call 刷新目錄結構(源文件的目錄TextBox.Text, 0) ' 子目錄深度ScrollBar.Max = subFolderMaxLeve子目錄深度ScrollBar.Value = 0 End SubPrivate Sub 獲取源文件目錄Button_Click()Dim path$, arr() As String源文件的目錄TextBox.Text = 選擇目錄()Call 刷新目錄結構(源文件的目錄TextBox.Text, 子目錄深度ScrollBar.Value) End SubPrivate Sub 成功日志TextBox_Change()successLogFile = 成功日志TextBox.Text End SubPrivate Sub 失敗日志TextBox_Change()errLogFile = 失敗日志TextBox.Text End SubPrivate Sub 跳過日志TextBox_Change()skipLogFile = 跳過日志TextBox.Text End SubPrivate Sub 子目錄深度ScrollBar_Change()子目錄深度TextBox.Value = 子目錄深度ScrollBar.ValueCall 刷新目錄結構(源文件的目錄TextBox.Text, 子目錄深度ScrollBar.Value) End SubPrivate Sub 處理時顯示文檔CheckBox_Change() On Error Resume NextshowDoc = 處理時顯示文檔CheckBox.ValuewordApp.Visible = showDoc End SubPrivate Sub start()' 選擇要處理的文件所在If 源文件的目錄TextBox.Text = "" Then源文件的目錄TextBox.Text = 選擇目錄()End IfIf MsgBox("要處理的文件在：" & 源文件的目錄TextBox.Text, vbYesNo + vbInformation, "確認源文件目錄") <> vbYes Then開始暫停ToggleButton.Caption = "開始"開始暫停ToggleButton.Value = FalseExit SubEnd IfCall 遍歷文件夾中對文檔的關鍵字打標記(源文件的目錄TextBox.Text, 完成文件的目錄TextBox.Text, 失敗文件的目錄TextBox.Text, 跳過文件的目錄TextBox.Text, 日志窗口TextBox) End SubPrivate Sub 開始暫停ToggleButton_Click()If 開始暫停ToggleButton.Value Then開始暫停ToggleButton.Caption = "暫停"Debug.Print 開始暫停ToggleButton.Value & "暫停"Call startElse開始暫停ToggleButton.Caption = "開始"Debug.Print 開始暫停ToggleButton.Value & "開始"End IfEnd SubPrivate Sub csdn博客Label_Click()Shell "cmd /c start https://jerryjin.blog.csdn.net/article/details/123596090", vbHide End SubPrivate Sub 刷新目錄結構(目標文件夾 As String, subLevel As Integer)Call 更新文件夾結構信息(目標文件夾, subLevel)子目錄深度ScrollBar.Max = subFolderMaxLeveinfoLog ("======================獲取目錄結構成功======================")Call infoLog(subFolderString, "", "", "", vbCrLf)End Sub

業務邏輯

遍歷文檔，查找替換的業務邏輯都在這。

遍歷文件使用了vba的 Dir("目標文件夾")方法。第一次目錄參數，第二次不帶參，就可以逐個返回下一文件，直到返回空字符串結束。

移動文件使用了：Scripting.FileSystemObject

輸出日志文件用的是 VBA的Shell "cmd.exe /c echo 日志內容 >> 日志文件", vbHide，第二個參數vbHide表示隱藏執行。

Option ExplicitPublic 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 ' 顯示wordPublic 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 clearLogCall infoLog("1. 初始化 word 對象……")Set wordApp = 獲取wordApp實例()wordApp.Visible = showDocCall infoLog("2. 初始化 word 對象完成！^_^")' 獲取個當前位置信息 ' currPath = ThisWorkbook.path & "\"CurrFileName = ThisWorkbook.NameCall infoLog("3. 定位當前文檔位置成功！")' 創建文件系統對象Set fs = CreateObject("Scripting.FileSystemObject")Call infoLog("4. 獲取 FileSystemObject 成功！")' 準備文件夾：復制文件夾結構If Dir(newPath, vbDirectory) = vbNullString Then Call 復制文件夾結構(sourceFilePath, newPath) 'MkDir newPathCall infoLog("5. 成功文件目錄準備完畢！")If Dir(skipPath, vbDirectory) = vbNullString Then Call 復制文件夾結構(sourceFilePath, skipPath) 'MkDir skipPathCall infoLog("6. 跳過文件目錄準備完畢！")If Dir(errPath, vbDirectory) = vbNullString Then Call 復制文件夾結構(sourceFilePath, errPath) ' MkDir errPathCall 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" ThentempFileName = sourceFilePath & CurrFileSet currDoc = wordApp.Documents.Open(tempFileName, Visible:=showDoc)' Debug.Print currDoc.Content' 找到關鍵字的，另存一份到 newPath 下If 對關鍵字打標記(currDoc) ThencurrDoc.SaveAs2 Filename:=tempNewPath & CurrFile, FileFormat:=wdFormatXMLDocumentKill tempFileNamecurrDoc.Close wdDoNotSaveChangesSet currDoc = Nothingsuccesslog tempFileNameUserForm1.成功數量TextBox.Value = UserForm1.成功數量TextBox.Value + 1ElsecurrDoc.Close wdDoNotSaveChangesSet currDoc = Nothingskiplog tempFileNameCall 移動文件(tempFileName, tempSkipPath & CurrFile)UserForm1.跳過數量TextBox.Value = UserForm1.跳過數量TextBox.Value + 1End IfEnd If NextFile:DoEvents' 如果按下暫停按鈕If UserForm1.開始暫停ToggleButton.Value = False ThenCall infoLog("暫停中。。。。。。")wordApp.Quit ' 關閉 wordExit SubEnd If' 優化性能每2000次重啟一下wordIf (0 + UserForm1.成功數量TextBox.Value + UserForm1.跳過數量TextBox.Value + UserForm1.失敗數量TextBox.Value) Mod 2000 = 0 ThenCall infoLog("優化性能：Word 重啟中。。。。。。")wordApp.Quit ' 關閉 wordSet wordApp = NothingSet wordApp = CreateObject("Word.Application")wordApp.Visible = showDocEnd IfCurrFile = Dir()Loop' ------------- 遍歷目錄中的文件結束 -------------Next' -------------------------- 遍歷目錄結束 --------------------------Set fs = Nothing' 處理完畢重置UIwordApp.Visible = TrueUserForm1.WebBrowser1.Visible = FalseUserForm1.處理時顯示文檔CheckBox.Value = TrueUserForm1.開始暫停ToggleButton.Caption = "開始"UserForm1.開始暫停ToggleButton.Value = False'wordApp.Quit ' 關閉 wordCall MsgBox("處理完畢，共處理 " & (0 + UserForm1.成功數量TextBox.Value + UserForm1.跳過數量TextBox.Value + UserForm1.失敗數量TextBox.Value) & "個文檔！", vbOKOnly + vbInformation, "溫馨提示")Exit Sub ErrorHandler:UserForm1.失敗數量TextBox.Value = UserForm1.失敗數量TextBox.Value + 1errlog "================================================================================"errlog "【錯誤文件】" & tempFileNameerrlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")Call 移動文件(tempFileName, tempErrPath & CurrFile)Resume NextFile End SubFunction 對關鍵字打標記(doc As Word.Document) On Error GoTo ErrorHandlerDim i As Integer, edited As Boolean ' 默認未編輯狀態falseCall 創建樣式(doc, STYLE_NAME)' 遍歷查找關鍵字，并標示。 keyArray = [0源字符, 1目標字符, 2替換方式, 3高亮]For i = 0 To keyArrLenWith 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_NAMEElse.Replacement.ClearFormattingEnd IfCall .Execute(Replace:=keyArray(i, 2)) NextKey:' 找到了關鍵字，標記為編輯過。If .Found Then edited = TrueEnd WithDoEventsNext對關鍵字打標記 = editedExit Function ErrorHandler:errlog "================================================================================"errlog "【對關鍵字打標記出錯】" & keyArray(i, 0)errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")Resume NextKey End FunctionFunction 創建樣式(doc As Word.Document, styleName As String) On Error Resume Next ' 出錯時忽略，繼續向下運行。' 判斷樣式，不存在則創建Dim flag As Booleanflag = doc.Styles(styleName).NameLocal = styleNameIf flag ThenExit FunctionEnd Ifdoc.Styles.Add Name:=styleName, Type:=wdStyleTypeCharacterWith doc.Styles(styleName).Font ' .NameFarEast = "微軟雅黑".Bold = True.Color = wdColorYellow.Shading.ForegroundPatternColor = wdColorAutomatic.Shading.BackgroundPatternColor = wdColorRedEnd WithEnd 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 StringFor i = 0 To arrLen - 1keyArray(i, 0) = myRanges(i + 1, dict.Item("源字符"))keyArray(i, 1) = myRanges(i + 1, dict.Item("目標字符"))If myRanges(i + 1, dict.Item("替換方式")) = "首個" ThenkeyArray(i, 2) = 1 ' wdReplaceOne 替換遇到的第一個匹配項。ElsekeyArray(i, 2) = 2 ' wdReplaceAll 替換所有匹配項。End IfkeyArray(i, 3) = "是"Next i獲取關鍵字 = keyArray End Function' 移動文件 Sub 移動文件(sourcePath As String, targetPath As String) On Error GoTo ErrorHandlerCall fs.moveFile(sourcePath, targetPath) Error_Handler_Exit:Exit Sub ErrorHandler:errlog "================================================================================"errlog "【移動文件失敗】" & sourcePatherrlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")Resume Error_Handler_Exit End Sub' 獲取word應用，失敗就創建一個新的 Function 獲取wordApp實例() On Error Resume NextSet 獲取wordApp實例 = GetObject(, "Word.Application")If Err.Number <> 0 ThenSet 獲取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, vbHideCall infoLog(logMsg, "【失敗】：") End Sub Sub skiplog(logMsg As String)Shell "cmd.exe /c echo " & logMsg & " >> " & skipLogFile, vbHideCall infoLog(logMsg, "【跳過】：") End Sub Sub successlog(logMsg As String)Shell "cmd.exe /c echo " & logMsg & " >> " & successLogFile, vbHideCall 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 = myConsoleWith 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 WithDoEvents End Sub Sub clearLog()myConsole.Text = "" End Sub

工具模塊

遍歷文件夾，看了網上的方案感覺效率不太給力，這里直接調CMD命令曲線救國了。dir C:\原目錄 /b/s *.doc?

批量拷貝目錄結構，不帶文件。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 IfEnd With End FunctionFunction 統計字符串出現次數(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 FunctionFunction 執行cmd命令(cmdStr As String) As String On Error Resume NextDim oShell As Object ' WScript.ShellDim oExec As Object ' WScript.Shell的Exec執行結果對象Set oShell = CreateObject("WScript.Shell")Set oExec = oShell.Exec("cmd /c " & cmdStr)執行cmd命令 = oExec.StdOut.ReadAlloShell.QuitSet oExec = NothingSet oShell = Nothing End Function' 刷新【子文件夾結構數組】【子文件夾最大深度】【子文件夾結構字符串】 Function 更新文件夾結構信息(目標文件夾 As String, depth As Integer) As String On Error Resume NextDim 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 arrLencurrDepth = 統計字符串出現次數(arr(i), "\") - baseDepthIf Len(arr(i)) = 0 Or currDepth > depth Thenarr(i) = DEL_FLAGElsearr(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 FunctionFunction 復制文件夾結構(原文件夾 As String, 目標文件夾 As String)Call 執行cmd命令("xcopy " & 原文件夾 & " " & 目標文件夾 & " /t/i") End FunctionFunction 移除末尾空行(myString As String)If Len(myString) > 0 ThenIf Right$(myString, 2) = vbCrLf Or Right$(myString, 2) = vbNewLine ThenmyString = Left$(myString, Len(myString) - 2)End IfEnd 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 Nextapp.ScreenUpdating = FalseEventState = app.EnableEventsapp.EnableEvents = FalseCalcState = app.Calculationapp.Calculation = xlCalculationManualPageBreakState = ActiveSheet.DisplayPageBreaksActiveSheet.DisplayPageBreaks = False End Sub ' 業務代碼結束后執行 Sub OptimizeCode_End(app As Object) On Error Resume NextActiveSheet.DisplayPageBreaks = PageBreakStateapp.Calculation = CalcStateapp.EnableEvents = EventStateapp.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關鍵字批量處理

總結

以上是生活随笔為你收集整理的VBA 收集 Word关键字批量处理-Excel版的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。

上一篇： Uva 1625 - Color Len
下一篇： mongoose 在数组中添加数据