背景：朋友工作中有多个Word文件，每次做更新时都要更新文档内的日期，每次手工更改都比较耗费时间，加上公司电脑不能装未授权的软件，且只支持英文，于是就根据这个需求，参考一些网上的代码，并做了一些升级，增加了界面、备份等功能，制作出这个VBA。下面是几个主要部分的VBA代码。

'窗体界面
Private Sub CommandButton1_Click() 'Replace按钮
Call Start_replace
Unload Me
End Sub

Private Sub CommandButton2_Click() 'Clear按钮
'CheckBox1.Value = False
'CheckBox2.Value = False
'CheckBox3.Value = False
'CheckBox4.Value = False
TextBox1.Value = ""
TextBox2.Value = ""
End Sub

'调用窗体界面(模块1)
Sub Replace_text()
UserForm1.Show
End Sub

'开始替换(模块2)
Public Sub Start_replace()
Application.ScreenUpdating = False  '关闭屏幕闪
Dim myFile$, myPath$, backup_file, Backup_path, i%, myDoc As Object, myBackup As Object, myAPP As Object, txt$, Re_txt$
Set myAPP = New Word.Application
With Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
    .Title = "选择目标文件夹"
    If .Show = -1 Then
        myPath = .SelectedItems(1) '读取选择的文件路径
    Else
        Exit Sub
    End If
End With
myPath = myPath & ""

MatchCase_Value = UserForm1.CheckBox1.Value
MatchWholeWord_Value = UserForm1.CheckBox2.Value
MatchByte_Value = UserForm1.CheckBox3.Value
MatchWildcards_Value = UserForm1.CheckBox4.Value
Backup = UserForm1.CheckBox5.Value
Be_replaced = UserForm1.TextBox1.Value
Replace_with = UserForm1.TextBox2.Value

txt = Be_replaced
Re_txt = Replace_with
myAPP.Visible = True '是否显示打开文档

'Backup
If (Backup = True) Then
    Backup_path = "E:\backup\"
    backup_file = Dir(myPath & "\*.doc*")
    Do While backup_file <> ""
        Set myBackup = myAPP.Documents.Open(myPath & "\" & backup_file)
        myBackup.SaveAs "E:\backup\" & backup_file
        myBackup.Close
        backup_file = Dir
    Loop
End If

'Replace
myFile = Dir(myPath & "\*.doc*")
Count = 0
Do While myFile <> "" '文件不为空
    Set myDoc = myAPP.Documents.Open(myPath & "\" & myFile)
    If myDoc.ProtectionType = wdNoProtection Then '是否受保护
        With myDoc.Content.Find
            .Text = txt
            .Replacement.Text = Re_txt
            .Forward = True
            .Wrap = 2
            .Format = False
            .MatchCase = MatchCase_Value
            .MatchWholeWord = MatchWholeWord_Value
            .MatchByte = MatchByte_Value
            .MatchWildcards = MatchWildcards_Value
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=2
        End With
    End If
    myDoc.Save
    myDoc.Close
    myFile = Dir
    Count = Count + 1
Loop
myAPP.Quit '关掉临时进程
Application.ScreenUpdating = True
If (Backup = True) Then
    MsgBox (Count & " documents replaced successfully and backup in " & Backup_path)
ElseIf (Backup = False) Then
    MsgBox (Count & " documents replaced successfully!")
End If
End Sub

• 不足之处：目前还只能对一个文件夹里的全部word批量替换，不能进行选择；不能实时查看到匹配到内容，所以建议替换时将文件拷贝到临时文件夹再进行替换。（尽管有备份功能）
• 本文Word下载地址

链接：https://pan.baidu.com/s/1ZsrfjK3GY4cLOlkm-h12rQ
提取码：mup5