word vba批量替换文件内容并批量修改文件名

最近在工作中遇到某一文件夹下的许多文件，名字和内容有大量需要替换，一个个手工替换很麻烦，于是修改了一段代码：

Sub 批量更改word要素编号及文件名() '此代码为指定文件夹中所有选取的WORD文件的进行格式设置
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, Doc As Document
Dim NewName As String, thisPath As String
' On Error Resume Next '忽略错误
'定义一个文件夹选取对话框
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
    .Filters.Clear '清除所有文件筛选器中的项目
    .Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
    .AllowMultiSelect = True '允许多项选择
    If .Show = -1 Then '确定
        myPas = InputBox("请输入替换成的编号：")
        Application.ScreenUpdating = False
      
        For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
          Set Doc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
         'Doc.Name = Replace(Doc.Name, "流程编号+", myPas)
        Doc.ActiveWindow.Selection.Find.Execute "流程编号+", , , , , , , , , myPas, wdReplaceAll
        ' Doc.SaveAs FileName:=Replace(vrtSelectedItem, "流程编号+", myPas)
 
        Doc.Close True
        
        '修改文件名
                NewName = Replace(vrtSelectedItem, "流程编号+", myPas&" ")
                If NewName <> "" Then
                    Name vrtSelectedItem As NewName
                End If
         Next
        Application.ScreenUpdating = True

    End If
End With
Set Doc = Nothing  '释放变量
MsgBox "编号更改完毕，请检查", vbInformation
End Sub