我已经获得了这段非常方便的代码,它通过 excel 按钮搜索文件夹并根据 Excel 工作表的 A 列和 B 列中输入的条件对所有 Word 文档执行查找和替换,它还提供了一个 msgbox 来显示如何已找到许多文件并进行了替换循环。此代码依次打开每个 word 文档,进行查找和替换,然后保存新文档。它还输出一个文本文件以报告更改的内容和位置。但!
我的问题是与报告 txt 文件有关,目前我认为它已设置(代码称为“whatchanged”)在每次循环通过 word docs 中的 Range 'Stories' 时写一行,因此它正在写重复的行在它搜索的每个故事的报告文件中,而不是仅在一行中搜索实际找到和替换的内容。
我正在努力想一种方法使此代码输出一行,仅显示更改的内容而没有任何重复。即使没有为每个范围故事进行查找和替换,它似乎也会在文本文件上输出一行!所以不是很有用...
如果有人能提出一种使报告文本文件更整洁的好方法,我将不胜感激?- 即只报告实际的查找和替换,没有重复的行。
您可以提供的任何帮助/建议将不胜感激,请注意,我是这个论坛和 vba 的新手,所以我正在尽我所能向他人学习和研究代码。我也发布了这个,希望如果你搜索类似的东西,这个代码也对其他人有用。
顺便说一句 .. 下面是一个仅针对一个测试文档的文本文件输出示例!,抱歉,如果这不是很清楚...这是在运行代码后创建的,并在 Excel 表上输入了一些测试查找和替换 - 你可以看到我对重复的意思:
文件、查找、替换、时间
H:\Letters Test\Doc1.doc|在字母中测试文本|替换文本|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|10 月|11 月|2013 年 10 月 15 日 11:06 :02
H:\Letters Test\Doc1.doc|VBA 测试员先生|Ms 测试|15/10/2013 11:06:02
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:02
H:\Letters Test\Doc1.doc|诚挚的|真诚的|2013 年 10 月 15 日 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 测试员|Ms 测试|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|VBA 测试员先生|Ms 测试|15/10/2013 11:06:03
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:03
H:\Letters Test\Doc1.doc|诚挚的|真诚的|2013 年 10 月 15 日 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 测试员|Ms 测试|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 月|2013 年 10 月 15 日 11:06 :04
H:\Letters Test\Doc1.doc|VBA 测试员先生|Ms 测试|15/10/2013 11:06:04
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:04
H:\Letters Test\Doc1.doc|诚挚的|真诚的|2013 年 10 月 15 日 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 测试员|Ms 测试|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|VBA 测试员先生|Ms 测试|15/10/2013 11:06:05
H:\Letters Test\Doc1.doc|2013|2014|15/10/2013 11: 06:05
H:\Letters Test\Doc1.doc|诚挚的|真诚的|2013 年 10 月 15 日 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