VBA 收集 Word关键字批量处理-Excel版
Posted 笑虾
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了VBA 收集 Word关键字批量处理-Excel版相关的知识，希望对你有一定的参考价值。
VBA 收集 Word关键字批量处理-Excel版
copy /b 图片.gif /b + 压缩包.zip /b 结果图片.gif
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_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 okBtn_Click()
' 选择要处理的文件所在
If 源文件的目录TextBox.Text = "" Then
源文件的目录TextBox.Text = 选择目录()
End If
If MsgBox("要处理的文件在：" & 源文件的目录TextBox.Text, vbYesNo + vbInformation, "确认源文件目录") <> vbYes Then
Exit Sub
End If
Call 遍历文件夹中对文档的关键字打标记(源文件的目录TextBox.Text, 完成文件的目录TextBox.Text, 失败文件的目录TextBox.Text, 跳过文件的目录TextBox.Text, 日志窗口TextBox)
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
业务逻辑
遍历文档，查找替换的业务逻辑都在这。
- 遍历文件使用了
vba的Dir("目标文件夹")方法。第一次目录参数，第二次不带参，就可以逐个返回下一文件，直到返回空字符串结束。 - 移动文件使用了：
Scripting.FileSystemObject - 输出日志文件用的是
VBA的Shell "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 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
' -------------------------- 遍历目录 开始 --------------------------
pathLen = UBound(subFolderArr)
For path_i = 0 To pathLen
sourceFilePath = subFolderArr(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:=newPath & 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, skipPath & CurrFile)
UserForm1.跳过数量TextBox.Value = UserForm1.跳过数量TextBox.Value + 1
End If
End If
NextFile:
CurrFile = Dir()
DoEvents
Loop
' ------------- 遍历目录中的文件 结束 -------------
Next
' -------------------------- 遍历目录 结束 --------------------------
Set fs = Nothing
UserForm1.WebBrowser1.Visible = False
wordApp.Visible = True
UserForm1.处理时显示文档CheckBox.Value = True
'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, errPath & CurrFile)
GoTo 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 ")
GoTo 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)
Exit Sub
ErrorHandler:
errlog "================================================================================"
errlog "【移动文件失败】" & sourcePath
errlog Err.Number & ":" & Replace(Err.Description, vbLf, " vbCrLf ")
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
工具模块
- 遍历文件夹，看了网上的方案感觉效率不太给力，这里直接调
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 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:
On Error Resume Next
Exit Function
Error_Handler:
Resume Error_Handler_Exit
End Function
Function 执行cmd命令(cmdStr As String如何用VBA宏程序将excel中的内容批量复制到word文档中去