请高手改一段宏，批量替换的谢谢

luckflay

Sub FindAndReplaceMultiItems()'Update by ExtendOffice 2018/10/25    Dim xFind As String    Dim xReplace As String    Dim xFindArr, xReplaceArr    Dim I As Long    Application.ScreenUpdating = False    xFind = InputBox("Enter items to be found here,seperated by comma: ", "Kutools for Word")    xReplace = InputBox("Enter new items here, seperated by comma: ", "Kutools for Word")    xFindArr = Split(xFind, ",")    xReplaceArr = Split(xReplace, ",")    If UBound(xFindArr) <> UBound(xReplaceArr) Then        MsgBox "Find and replace characters must be equal.", vbInformation, "Kutools for Word"        Exit Sub    End If    For I = 0 To UBound(xFindArr)        Selection.HomeKey Unit:=wdStory        With Selection.Find            .ClearFormatting            .Replacement.ClearFormatting            .Text = xFindArr(I)            .Replacement.Text = xReplaceArr(I)            .Format = False            .MatchWholeWord = False        End With        Selection.Find.Execute Replace:=wdReplaceAll    Next    Application.ScreenUpdating = TrueEnd Sub
这是代码，我想输入用，号分隔的单词后，查找完成后改成红色，这个是替换的。 新手小白一个，不懂VB，谢谢老师了

luckflay

Sub FindAndReplaceMultiItems()
'Update by ExtendOffice 2018/10/25
    Dim xFind As String
    Dim xReplace As String
    Dim xFindArr, xReplaceArr
    Dim I As Long
    Application.ScreenUpdating = False
    xFind = InputBox("Enter items to be found here,seperated by comma: ", "Kutools for Word")
    xReplace = InputBox("Enter new items here, seperated by comma: ", "Kutools for Word")
    xFindArr = Split(xFind, ",")
    xReplaceArr = Split(xReplace, ",")
    If UBound(xFindArr) <> UBound(xReplaceArr) Then
        MsgBox "Find and replace characters must be equal.", vbInformation, "Kutools for Word"
        Exit Sub
    End If
    For I = 0 To UBound(xFindArr)
        Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = xFindArr(I)
            .Replacement.Text = xReplaceArr(I)
            .Format = False
            .MatchWholeWord = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    Next
    Application.ScreenUpdating = True
End Sub

ming0018

只是查找，并标红是吗？
是的话，一会给你写一个。

ming0018

1. Sub FindMultiItems()
   
2.     Dim xFind As String
   
3.     Dim xFindArr
   
4.     Dim I As Long
   
5.     Dim Rng As Range
   
6.     Application.ScreenUpdating = False
   
7.     xFind = InputBox("Enter items to be found here,seperated by comma: ", "Kutools for Word")
   
8.     xFindArr = Split(xFind, ",")
   
9.     For I = 0 To UBound(xFindArr)
   
10.         Set Rng = ActiveDocument.Content
    
11.         With Rng.Find
    
12.             .ClearFormatting
    
13.             .Replacement.ClearFormatting
    
14.             .Text = xFindArr(I)
    
15.             .Replacement.Font.ColorIndex = wdRed
    
16.             .Execute Replace:=wdReplaceAll
    
17.         End With
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

luckflay

谢谢了，谢谢了，谢谢了，

luckflay

能否改一下代码，太分散了。谢谢