如何使用VBA在Word中一次替换形状中的单词（不在形状中循环）

我有一个包含大约1000个单词对的列表供替换。通过循环形状，我必须一次又一次地循环单词对。为了让它运行得更快，我尝试在执行替换之前选择所有形状，但没有成功。如有任何建议，将不胜感激

当前代码的相关部分（成对存储在名为key（）的列表和名为oDic的字典中）：

---

请注意，您的具体问题的答案是：否，使用VBA在Word中不可能一次替换所有形状中的单词（不在形状中循环）

然而，我的印象是，您真正感兴趣的是如何优化代码这一更普遍的问题。下面是一个解决方案

我建议在注释中实现

Trie

，但经过进一步考虑，我认为内置的

Scripting.Dictionary

对象足以满足您的需要

我建议您加载一个

Scripting.Dictionary

，其中包含要查找的单词（作为键）和替换的单词（作为值）。您可以循环一次每个形状的单词，并检查

Scripting.Dictionary

以查看它是否存在。如果有，请更换；如果没有，就别管它

我创建了一个矩形，文本为“此形状中有单词”find”，其中“find”为粗体和红色。我对它运行了一个测试，将“find”替换为“replace”，并保留了格式

以下是示例代码：

Public Sub Main()
    Dim dictFindReplace As Scripting.Dictionary

    Set dictFindReplace = New Scripting.Dictionary

    'Add all your words to the dictionary here
    dictFindReplace.Add "find", "replace"

    'Loop through all the shapes
    For i = 1 To ActiveDocument.Shapes.Count

        'If the shape has text
        If ActiveDocument.Shapes(i).TextFrame.HasText Then
            With ActiveDocument.Shapes(i).TextFrame.TextRange.Words
                'Loop through each word. This method preserves formatting.
                For j = 1 To .Count

                    'If a word exists in the dictionary, replace the text of it, but keep the formatting.
                    If dictFindReplace.Exists(.Item(j).Text) Then
                        .Item(j).Text = dictFindReplace.Item(.Item(j).Text)
                    End If
                Next
            End With
        End If
    Next i

End Sub

---

您可能要添加当前代码？至于你的问题，我认为除了循环之外没有别的办法。太好了。@L42，谢谢你的信息和建议。我添加了我的代码：）你在“形状”中的意思是什么？你应该意识到，即使有一种方法可以做到“不循环”，循环仍然会在幕后发生。如果要隐藏循环，请将赋值封装到函数中或隐藏类中的详细信息。至于优化代码速度的提示，请尝试使用

Replace

而不是当前使用的更高级的查找和替换功能。我猜，对于如此少量的文本，使用

Find

的设置和拆卸成本会很快增加。如果您想进一步优化它，可以实现一个trie数据结构来存储键/值对，然后自己解析形状字符串。当你处理每个单词时，你会试图一个字母一个字母地在trie中导航。如果存在，则替换；如果不存在，则保持输出中的状态。当然，不必在代码中添加所有1000字的查找/替换对。您可以从文本文件或Excel文档等外部源加载它们。谢谢您的回答！这种方法的问题似乎是，对于汉语、日语和其他没有空格分隔的语言，无法通过.Textrange.words解析单词。此外，即使是在英语中，有些配对词实际上是短语而不是单个单词。我很害怕：（在这种情况下，Trie和逐个字符的解析可能仍然是最好的选择。如果我有机会，我会尝试一下……如果其他人想用我的答案来制作他们自己的答案，请放心！

Public Sub Main()
    Dim dictFindReplace As Scripting.Dictionary

    Set dictFindReplace = New Scripting.Dictionary

    'Add all your words to the dictionary here
    dictFindReplace.Add "find", "replace"

    'Loop through all the shapes
    For i = 1 To ActiveDocument.Shapes.Count

        'If the shape has text
        If ActiveDocument.Shapes(i).TextFrame.HasText Then
            With ActiveDocument.Shapes(i).TextFrame.TextRange.Words
                'Loop through each word. This method preserves formatting.
                For j = 1 To .Count

                    'If a word exists in the dictionary, replace the text of it, but keep the formatting.
                    If dictFindReplace.Exists(.Item(j).Text) Then
                        .Item(j).Text = dictFindReplace.Item(.Item(j).Text)
                    End If
                Next
            End With
        End If
    Next i

End Sub