Excel VBA宏，使用輸出文本文件查找和替換Word文檔中的文本

Question

我已經獲得了這段非常方便的代碼，可以通過excel按鈕搜索文件夾，並根據Excel工作表的A和B列中輸入的條件對所有Word文檔執行查找和替換，它還提供了一個msgbox來顯示如何找到了許多文件，並進行了替換循環。 此代碼依次打開每個Word文檔，進行查找和替換，然后保存新文檔。 它還輸出一個文本文件，以報告發生了什么更改以及更改的位置。 但！

我的問題是與該報告txt文件有關，目前，我認為它已被設置（稱為“ whatchanged”），每次在docs文檔中的范圍“ Stories”中循環時都寫一行，因此它正在寫重復的行在報告文件中，它會針對每個故事進行搜索，而不是僅對一行內容進行實際查找和替換。

我正在努力想辦法使此代碼輸出僅一行以顯示更改的內容而沒有任何重復。 即使沒有為每個范圍故事進行查找和替換，它似乎也會在文本文件上輸出一行！ 所以不是很有用...

如果有人可以提出一種使報告文本文件更整潔的好方法，我將不勝感激？ -即僅報告實際的查找和替換，沒有重復的行。

您能提供的任何幫助/建議都將不勝感激，請注意，我是這個論壇和vba的新手，所以我正在盡最大努力向他人學習和研究代碼。 我也發布了此代碼，希望如果您搜索類似的代碼，該代碼也可能對其他人有用。

btw ..這是下面一個僅輸出一個測試文檔的文本文件的示例！，抱歉，如果這不是很清楚...這是在運行代碼后進行一些測試查找后創建的，並替換為在Excel工作表上輸入的-您可以看到我對重復的意思：

文件，查找，替換，時間

H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:02
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|忠實的您| 15/10/2013 11:06:02
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:02
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|您忠實的| 15/10/2013 11:06:03
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:03
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|您忠實的| 15/10/2013 11:06:03
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:03
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|您忠實的| 15/10/2013 11:06:04
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:04
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|您忠實的| 15/10/2013 11:06:04
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:04
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|真誠的用戶| 15/10/2013 11:06:05
H：\\ Letters Test \\ Doc1.doc |字母測試文字|替換文字| 15/10/2013 11:06:05
H：\\ Letters Test \\ Doc1.doc | 10月| 11月| 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 |您真誠的|真誠的用戶| 15/10/2013 11:06:05

碼：

'~~> 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

Answer 1

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

Answer 2

我看到兩個選擇：

1）在將字符串寫入文件之前，先編寫條件；
2）您在文件上執行一些VBA，以過濾重復的字符串。

考慮到第一種選擇，您可以采用以下幾種方法：

1）讀取文件並將新字符串與文件中已有的字符串進行比較：但這將花費很長時間；
2）將先前的字符串存儲在數組中，並檢查新的字符串是否已在數組中：由於該過程在內存中進行，因此速度更快。
3）如果搜索字符串的長度可以接受，我個人會使用字典。 字典具有一種結構，您可以在其中存儲鍵值對記錄。
字典具有典型的Exists方法，該方法檢查結構中是否已存在某個鍵。 我認為此鍵不允許使用空格，但是您可以使用下划線替換這些空格。
在這種情況下，您可以將每個搜索字符串作為關鍵字存儲在字典中，但前提是該關鍵字（搜索字符串）尚不存在。

字典的結構：

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 

讓我知道這是否有幫助，或者您是否需要更多有關此主題的幫助。