同一个word文档内不同文本替换不同文本的VBA

snow653124

公司系统有点傻，导出的项目命名只能是订单1、订单2、订单3等

但是出版的时候，要把这些个根据订单的名字重新命名，少了还好，一旦多了，纯手工是个无脑的体力劳动，还容易出错。
想求一个代码，支持word内不同文本替换不同文本，文本逐行对应来替换
我上传2个例子，用文档示例2中的文本逐行对应替换文档示例1中的文本。
文档示例1肯定在word格式，至于文档示例2中的文字，可以在word、记事本或者excel均可

有工具、代码都可以，可以支持收费，谢谢了。

2489586288

用代码吧，不过实际文件就是这样简单纯粹的吗？

daibao88

Sub 批量替换()
    Application.DisplayAlerts = False
    Dim rg As Range, arrold, arrnew, i As Integer
    Set rg = ActiveDocument.Range
    arrold = Array("6", "2", "3")
    arrnew = Array("六", "二", "三")
    If UBound(arrold) <> UBound(arrnew) Then MsgBox "替换与被被替换词量不对称，程序退出": Exit Sub
    For i = 0 To UBound(arrold)
        rg.Find.ClearFormatting
        rg.Find.Replacement.ClearFormatting
        With rg.Find
            .Text = arrold(i)
            .Replacement.Text = arrnew(i)
            .Execute Replace:=wdReplaceAll
        End With
        rg = ActiveDocument.Range
    Next
    Application.DisplayAlerts = True
End Sub
原来的，两个数组的来源改成从2个文档读取，split后得到即可。自己改下吧。

snow653124

实际的文档除了这字，就是图片，基本上就是这个东西

snow653124

daibao88 发表于 2020-2-16 09:20
Sub 批量替换()
    Application.DisplayAlerts = False
    Dim rg As Range, arrold, arrnew, i As Int ...

谢谢 我试试代码基础几乎为0
我百度一点一点试试

weiyingde

snow653124 发表于 2020-2-16 10:06
谢谢 我试试代码基础几乎为0
我百度一点一点试试

如果两个的顺序一致，那就填没有意思的。
Sub 群体替换()Dim arr, brr, idoc As Document, xdoc As Document
With ActiveDocument.Content
     .Find.Execute "^13^13", , , , , , , , , "^p", 2
     arr = Split(.Text, Chr(13))
End With
Set idoc = Documents.Open(ThisDocument.Path & "\" & "替换的顺序.doc")
brr = Split(idoc.Content, Chr(13))
idoc.Close False
Set xdoc = Documents.Open(ThisDocument.Path & "\" & "被替换的文档.doc")
With xdoc
     For i = 1 To .Paragraphs.Count
        For j = 0 To UBound(arr) - 1
            With .Paragraphs(i)
                 If Left(.Range.Text, Len(.Range.Text) - 1) = brr(j) Then
                   '.Range = arr(j) & Chr(13)
                   xdoc.Range(.Range.Start, .Range.Start + Len(.Range.Text) - 1) = arr(j)
                 End If
            End With
        Next
    Next
End With
xdoc.Save
xdoc.Close
End Sub
如果合适，赏朵小花。
附件如下：

weiyingde

若被替换的文档中被替换的词语位于该段不同位置，又该如何。
提示：每一段有一个被替换的词语。
见附件中被替换的文档。

snow653124

weiyingde 发表于 2020-2-20 20:14
若被替换的文档中被替换的词语位于该段不同位置，又该如何。
提示：每一段有一个被替换的词语。
见附件中 ...

万分感谢了

lisga1103

weiyingde 发表于 2020-2-20 20:14
若被替换的文档中被替换的词语位于该段不同位置，又该如何。
提示：每一段有一个被替换的词语。
见附件中 ...

附件中“被替换的文档 .doc”点之前多了个空格，与代码中的名称不符，运行是会报错。
另外，运行后被替换的文档并未发生变化，也就是说没有被替换，不知何故？

weiyingde

lisga1103 发表于 2020-7-1 10:29
附件中“被替换的文档 .doc”点之前多了个空格，与代码中的名称不符，运行是会报错。
另外，运行后被替 ...

Sub 这个试试()
Dim arr, brr, idoc As Document, xdoc As Document
With ActiveDocument.Content
     .Find.Execute "^13^13", , , , , , , , , "^p", 2
     arr = Split(.Text, Chr(13))
End With
Set idoc = Documents.Open(ThisDocument.Path & "\" & "替换的顺序.doc")
brr = Split(idoc.Content, Chr(13))
idoc.Close False
Set xdoc = Documents.Open(ThisDocument.Path & "\" & "被替换的文档.doc")
For Each br In brr
   N = N + 1
   With xdoc.Content.Find
        Do While .Execute(br)
                 With .Parent
                      If .Text = br Then .Text = arr(N - 1)
                      .Collapse 0
                 End With
        Loop
  End With
Next
End Sub

可以的话，赏多小花。