[已解决]eXCEL改word批量替换

釜底抽薪

表格中   A2 是要查找的内容
             B2 是要替换的内容
      就是替换不起 求大神帮忙指导下

Sub 批量写入()
Dim ar
ar = [{"查找字符","替换字符"}]
[a1].Resize(, UBound(ar)) = ar
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要处理的数据所在的文件夹"
        If .Show Then
            mypath = .SelectedItems(1)
        Else
            MsgBox "对不起,你没有告诉我要处理的工作簿在哪个文件夹", vbExclamation, "温馨提示"
            Exit Sub
        End If
    End With
mypath = IIf(Right(mypath, 1) <> "\", mypath & "\", mypath)
myname = Dir(mypath & "*.doc*")
   Application.ScreenUpdating = True
    Do While myname <> ""
            Set wdapp = CreateObject("word.application")
            wdapp.Documents.Open Filename:=mypath & myname
            wdapp.Visible = True
            wdapp.Selection.Find.Replacement.ClearFormatting
            With wdapp.Selection.Find
                .Text = Range("A2")
                .Replacement.Text = Range("B2")
            End With
            wdapp.Selection.Find.Execute Replace:=wdReplaceAll
            wdapp.Documents.Save
            wdapp.Application.Quit
            Set wdapp = Nothing
          myname = Dir
    Loop
Application.ScreenUpdating = False
    MsgBox "完成替换"
End Sub

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2021-12-7 19:58

Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]
[a1].Resize(, UBound(ar)) = ar
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要处理的数据所在的文件夹"
        If .Show Then
            mypath = .SelectedItems(1)
        Else
            MsgBox "对不起,你没有告诉我要处理的工作簿在哪个文件夹", vbExclamation, "温馨提示"
            Exit Sub
        End If
    End With
mypath = IIf(Right(mypath, 1) <> "\", mypath & "\", mypath)
myname = Dir(mypath & "*.docx*")
Set wdapp = CreateObject("word.application")
    Do While myname <> ""
        Set word = wdapp.Documents.Open(Filename:=mypath & myname)
        Set con = word.Content
        con.Find.Execute findtext:=Range("A2").Value, replacewith:=Range("B2").Value, Replace:=2
        word.Save
        word.Close
        Set word = Nothing
        myname = Dir
    Loop
    wdapp.Application.Quit
    Set wdapp = Nothing
    MsgBox "完成替换"
End Sub

跳转到最佳答案楼层

大灰狼1976

Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]
[a1].Resize(, UBound(ar)) = ar
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要处理的数据所在的文件夹"
        If .Show Then
            mypath = .SelectedItems(1)
        Else
            MsgBox "对不起,你没有告诉我要处理的工作簿在哪个文件夹", vbExclamation, "温馨提示"
            Exit Sub
        End If
    End With
mypath = IIf(Right(mypath, 1) <> "\", mypath & "\", mypath)
myname = Dir(mypath & "*.docx*")
Set wdapp = CreateObject("word.application")
    Do While myname <> ""
        Set word = wdapp.Documents.Open(Filename:=mypath & myname)
        Set con = word.Content
        con.Find.Execute findtext:=Range("A2").Value, replacewith:=Range("B2").Value, Replace:=2
        word.Save
        word.Close
        Set word = Nothing
        myname = Dir
    Loop
    wdapp.Application.Quit
    Set wdapp = Nothing
    MsgBox "完成替换"
End Sub

zjdh

替换word文本.rar (357.86 KB, 下载次数: 15)

2021-12-7 20:16 上传

点击文件名下载附件

釜底抽薪

zjdh 发表于 2021-12-7 20:16

我也发现问题了
Replace:=wdReplaceAll    这给参数出了问题，在EXCELvba中 应当写2

jian82372387

请问大神如果要查找某个关键字把整个句子复制出来到EXCEL中，要修改哪里啊？？

jian82372387

请问大神如果要查找某个关键字把整个句子复制出来到EXCEL中，要修改哪里啊？？

a7liyan

大灰狼1976 发表于 2021-12-7 19:58
Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]

真是秀呀！找了好久终于找到！

a7liyan

大灰狼1976 发表于 2021-12-7 19:58
Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]

能不能多个替换，例如A换成大师1，B换成大师2,C换成大师3！等等，谢谢！

果冻的心

可

SON3891

大灰狼1976 发表于 2021-12-7 19:58
Sub 批量写入()
Dim ar, con, word
ar = [{"查找字符","替换字符"}]

大师阿，能不能改成批量 A，B，C，D，E，这种的，循环批量，这个要是有以后这种就是万版了，，，电脑存了只有批量生成指定模板的，，你这个做了就变万能的了，