Excel VBA 宏，在 Word 文档中查找和替换文本，带有输出文本文件

Excel VBA Macro, Find and Replace text in Word Documents, with an output text file

提问by Alex H

I have aquired this very handy piece of code that via an excel button searches through a folder and performs a find and replace on all word documents depending on criteria input in column A and B of an Excel worksheet, it also provides a msgbox to show how many files have been found and replacement loops have been made. This code opens each word document in turn, does the find and replace, then saves the new document. It also outputs a text file to report what has changed and where. BUT!

我已经获得了这段非常方便的代码，它通过一个 excel 按钮搜索文件夹并根据 Excel 工作表 A 和 B 列中输入的条件对所有 Word 文档执行查找和替换，它还提供了一个 msgbox 来显示如何找到了许多文件并进行了替换循环。此代码依次打开每个 Word 文档，进行查找和替换，然后保存新文档。它还输出一个文本文件来报告更改的内容和位置。但！

My question is to do with that reporting txt file, currently I think it is set up (code called 'whatchanged') to write a line each time it cycles through the Range 'Stories' within the word docs, it is therefore writing duplicate lines on the report file for each story it searches through rather than just one line for what has actually been found and replaced.

我的问题是与那个报告 txt 文件有关，目前我认为它被设置（代码称为“whatchanged”）在每次循环遍历 word docs 中的范围“故事”时写一行，因此它会写重复的行在它搜索的每个故事的报告文件中，而不是仅一行显示实际找到和替换的内容。

I'm struggling to think of a way to make this code output one line only to show what has changed without any duplicates. It also seems to output a line on the text file even when no find and replace has been made for each range story! so not very useful...

我正在努力想办法让这段代码输出一行，只显示发生了什么变化而没有任何重复。即使没有为每个范围故事进行查找和替换，它似乎也会在文本文件上输出一行！所以不是很有用...

I would be really grateful if someone could perhaps suggest a good way to make the reporting text file tidier? - i.e only reporting on the actual find and replace made, with no duplicate lines.

如果有人可以提出一种使报告文本文件更整洁的好方法，我将不胜感激？- 即只报告实际的查找和替换，没有重复的行。

Any help /suggestions you could give will be very much appreciated, note that I'm new to this forum and to vba so i'm trying my best to learn from others and research code as i go. I also posted this in the hope this code may be useful to others too if your searching for something similar.

您可以提供的任何帮助/建议将不胜感激，请注意，我是这个论坛和 vba 的新手，所以我正在尽最大努力向他人学习并研究代码。我也发布了这个，希望这个代码对其他人也有用，如果你正在寻找类似的东西。

btw.. Heres an example below of the text file output for just one test document!, sorry if this isnt very clear... this was created after running the code with a few testing find and replaces being entered on the excel sheet - you can see what i mean about the duplication:

btw .. 下面是一个测试文档的文本文件输出示例！，对不起，如果这不是很清楚......这是在运行代码后创建的，并在excel表上输入了一些测试查找和替换 - 你可以看到我对重复的意思：

File, Find, Replacement, Time

H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|Testing text in letter|Replacement text|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|Mr VBA Tester|Ms Testing|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|Yours Sincerely|Yours Faithfully|15/10/2013 11:06:05

文件、查找、替换、时间

H:\Letters Test\Doc1.doc|字母中的测试文本|替换文本|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06 :02
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:02
H:\Letters Test\Doc1.doc|您真诚的|您忠实的|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|信件中的测试文本|替换文本|15/10 /2013 11:06:02
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/ 10/2013 11:06:02
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|此致|您诚挚的|15/ 10/2013 11:06:03
H:\Letters Test\Doc1.doc|字母中的测试文本|替换文本|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06 :03
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11： 06:03
H:\Letters Test\Doc1.doc|您真诚的|您忠实的|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|信件中的测试文本|替换文本|15/10 /2013 11:06:03
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/ 10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|此致|您诚挚的|15/ 10/2013 11:06:04
H:\Letters Test\Doc1.doc|字母中的测试文本|替换文本|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06 :04
H:\Letters Test\Doc1.doc|VBA 测试先生|测试女士|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:04
H:\Letters Test\Doc1.doc|您真诚的|您忠实的|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|测试文字中的文字|替换文字|15/10 /2013 11:06:04
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/ 10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|此致|您诚挚的|15/ 10/2013 11:06:05
H:\Letters Test\Doc1.doc|字母中的测试文本|替换文本|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|October|November|15/10/2013 11:06 :05
H:\Letters Test\Doc1.doc|VBA 测试员先生|测试女士|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11： 06:05
H:\Letters Test\Doc1.doc|您真诚的|您忠实的|15/10/2013 11:06:05

Code:

代码：

'~~> Defining Word Constants
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2

Public FileNum As Integer
Public OutputTxt As String


Sub WordReplace(sFolder, savePath)
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim strFilePattern As String
Dim strFileName As String, sFileName As String
Dim rngXL As Range
Dim x As Range
Dim strFind As String
Dim strReplace As String
Dim whatChanged As String

'~~> This is the extention you want to go in for
strFilePattern = "*.do*"

'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")

If Err.Number <> 0 Then
    Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0

oWordApp.Visible = True

'~~> Loop through the folder to get the word files

strFileName = Dir$(sFolder & "\" & strFilePattern)


whatChanged = "File, Find, Replacement, Time" & vbCrLf
Print #FileNum, whatChanged

Dim i, j
    i = 0 ' count of files found
    j = 0 ' count of files that matched

Do Until strFileName = ""

    i = i + 1

    sFileName = sFolder & "\" & strFileName

    '~~> Open the word doc
    Set oWordDoc = oWordApp.Documents.Open(sFileName)
    Set rngXL = Sheets(1).Range("A2:A" & Range("A2").End(xlDown).Row)

    '~~> Do Find and Replace
    For Each rngStory In oWordDoc.StoryRanges

        For Each x In rngXL
            strFind = x.Value
            strReplace = x.Offset(0, 1).Value
            j = j + 1
            With rngStory.Find
                .text = strFind
                .Replacement.text = strReplace
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
           whatChanged = sFileName & "|" & strFind & "|" & strReplace & "|" & Now()
           Print #FileNum, whatChanged
        Next

    Next

    '~~> Close the file after saving
    oWordDoc.Close SaveChanges:=True

    '~~> Find next file
    strFileName = Dir$()
Loop

'Call writeToFile(whatChanged, savePath)

MsgBox ("Found " & i & " files and " & j & " replacements made")

'~~> Quit and clean up
oWordApp.Quit

Set oWordDoc = Nothing
Set oWordApp = Nothing

End Sub

Sub writeToFile(text, path)
Set objFso = CreateObject("Scripting.FileSystemObject")

Dim objTextStream
Set objTextStream = objFso.OpenTextFile(path, 8, True)

'Display the contents of the text file
objTextStream.WriteLine text

'Close the file and clean up
objTextStream.Close
Set objTextStream = Nothing
Set objFso = Nothing
End Sub


Private Sub Button1_Click()
Dim objFileClass As FileClass
Set objFileClass = New FileClass

Dim searchPath, savePath
searchPath = objFileClass.SelectFolder

FileNum = FreeFile

OutputTxt = searchPath & "\FindAndReplaceAuditFile.TXT"

Open OutputTxt For Output As FileNum

Call WordReplace(searchPath, savePath)

Close #FileNum

End Sub

采纳答案by Roman Plischke

The Find.Executemethod returns boolean on success. So you can write a log line only after successful replacing:

该Find.Execute方法返回布尔成功。所以只有替换成功后才能写日志行：

With rngStory.Find
  .text = strFind
  .Replacement.text = strReplace
  .Wrap = wdFindContinue
  If .Execute(Replace:=wdReplaceAll) Then
    whatChanged = sFileName & "|" & strFind & "|" & strReplace & "|" & Now()
    Print #FileNum, whatChanged
  End If
End With

回答by Trace

I see two options:

我看到两个选项：

1) You write a condition before writing the string to the file;
2) You execute some VBA on the file to filter duplicate strings.

1）在将字符串写入文件之前写入条件；
2) 您对文件执行一些 VBA 以过滤重复的字符串。

Considering the first option, there are a few ways you can go:

考虑到第一个选项，您可以采用以下几种方法：

1) Read the file and compare the new string to what is already in the file: but this would take a long time;
2) Store the previous strings in an array and check if the new string is already in the array: this will be faster, since the process happens in memory;
3) Personally I would go with a dictionary, if the length of the search string is acceptable. A dictionary has a structure where you can store key - value pair records.
The dictionary has a typical Existsmethod that checks whether a certain key already exists in the structure. I don't think that this key allows spaces, but you can replace these spaces by underscores.
In this case you would store each search string as a key in the dictionary, on the condition that the key (the search string) does not exist yet.

1）读取文件并将新字符串与文件中已有的字符串进行比较：但这需要很长时间；
2) 将之前的字符串存储在数组中并检查新字符串是否已经在数组中：这会更快，因为该过程发生在内存中；
3）如果搜索字符串的长度可以接受，我个人会使用字典。字典具有可以存储键值对记录的结构。
字典有一个典型的Exists方法是检查结构中是否已经存在某个键。我不认为这个键允许空格，但你可以用下划线替换这些空格。
在这种情况下，您会将每个搜索字符串作为键存储在字典中，条件是该键（搜索字符串）尚不存在。

The structure of a dictionary:

字典的结构：

Dim dict As New Scripting.Dictionary 
dim sFind_value as string
dim sKey as string    
dim sValue as string

sFind_value = trim("whatever value")
sKey = replace(sFind_value, " ", "_")
sValue = "whatever"

If Not dict.Exists(sKey) Then 
    dict.Add sKey, sValue
    'Write to file
End If 

Let me know if this is helpful, or if you need more help on the subject.

让我知道这是否有帮助，或者您是否需要有关该主题的更多帮助。