求修改一文件替换工具

hgyw

本人小白一枚，但因工作需要网上找到了一个文档替换工具，但是我希望可以增加下面两项功能，望大侠赐教！
要求：
1.文件替换后自动保存文件名为红框内的名字（后面加资料2字）
2.文件替换后自动打开新文件（于核对有没有替换错误）

代码：
'文件替换（选择替换文件，并将替换后的文件保存在当前路径下新文件夹文件中）
Private Sub CommandButton2_Click()
    Dim tmp, Target, myFile(100)
    Dim sPath As String, sFile As String
    Dim sFind(100) As String, sRepl(100) As String
    Dim objFDir As Object
    Dim k, kk, WordNo, FileNo As Integer

    '读取替换内容
    For k = 2 To 100
       tmp = ActiveDocument.Tables(1).Cell(k, 1)
       sFind(k) = Left(tmp, Len(tmp) - 2)
       tmp = ActiveDocument.Tables(1).Cell(k, 2)
       sRepl(k) = Left(tmp, Len(tmp) - 2)
       If sFind(k) = "" Then Exit For
    Next k
    WordNo = k - 1
   '选择目录
    Set objFDir = Application.FileDialog(msoFileDialogFilePicker)
    With objFDir
        '设置文件过滤器
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Word Files", "*.doc, *.docx, *.wps"
        .Filters.Add "All Files", "*.*"

        If .Show = -1 Then
            ' 如果单击了确定按钮(-1)，则将选取的路径保存在变量中。
            FileNo = .SelectedItems.Count
            k = InStrRev(.SelectedItems(1), "\")
            sPath = Left(.SelectedItems(1), k - 1)
            For kk = 1 To FileNo
                k = InStrRev(.SelectedItems(kk), "\")
                myFile(kk) = Right(.SelectedItems(kk), Len(.SelectedItems(kk)) - k)
                Debug.Print sPath & "\" & myFile(kk)
            Next kk
        Else
            Exit Sub     '取消按钮（0）
        End If
    End With
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    If Dir(sPath & "\新文件夹", vbDirectory) = "" Then MkDir sPath & "\新文件夹"
    '开始替换
    For kk = 1 To FileNo
        Target = sPath & "\" & myFile(kk)
        Debug.Print Target
        Documents.Open Target

        For k = 2 To WordNo
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = sFind(k)
                .Replacement.Text = sRepl(k)
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                '执行替换
                .Execute Replace:=wdReplaceAll
            End With
        Next k
        ActiveDocument.SaveAs FileName:=sPath & "\新文件夹\" & myFile(kk)
        'ActiveDocument.Save
        ActiveDocument.Close
    Next kk

    MsgBox "共有" & FileNo & "个文件替换完毕！"
End Sub

413191246se

楼主，请上附件说明问题。