Question

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

我的问题是与报告txt文件有关，目前我认为它是设置的（代码称为'whatchanged'）每次循环通过单词docs中的Range'Stories'时写一行，因此它是在报告文件中为其搜索的每个故事写下重复的行，而不是仅仅找到一条实际找到和替换的行。

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

如果有人能提出一个让报告文本文件更整洁的好方法，我真的很感激？ - 即仅报告实际的查找和替换，没有重复的行。

您可以给予任何帮助/建议，非常感谢，请注意我是这个论坛的新手，并且我正努力向其他人学习并研究代码。我也发布了这个，希望如果您搜索类似的东西，这些代码也可能对其他人有用。

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

文件，查找，替换，时间

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 | 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 | 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 |您诚挚的|您的忠诚| 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 | 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 | 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先生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

如果这有用，或者您需要有关该主题的更多帮助，请告诉我。

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

2 个答案: