如何从 VBA Find 中获取找到结果的所有值？

Question

我正在编写一个宏，它应该将所有找到的值打印到一个文本文件中。到目前为止，我得到了 find 宏，找不到可以获取每个找到结果的每个值的部分。

Sub ReplaceAndWrite()

Dim TextFile As Integer

Dim FilePath As String

Dim FileName As String

 FileName = ActiveDocument.Name

FilePath = ActiveDocument.Path & "\" & FileName & ".txt"

TextFile = FreeFile

Open FiledPath For Output As TextFile

With ActiveDocument.Range

With .Find

  .ClearFormatting

  .Replacement.ClearFormatting

  .Text = "(#VL-*>) <[! ,^13]@#"

  .ReplacementText = "\1"

  .Forward = True

  .Wrap = wdFindContinue

  .Format = False

  .MatchWildcards = True

  With .Replacement

   .ClearFormatting

   .Font.Bold = True

   .Font.ColorIndex = wdBlue

   .Font.Underline = True

   .Font.AllCaps = True

  End With

.MatchCase = False

.Execute Replace:=wdReplaceAll

End With

End With

Close TextFile

End Sub

如何将找到的结果写入文本文件？ 是否可以遍历所有结果并将它们的值写入文本文件？ 有没有更好的方法来完成这样的任务？

Answer 1

以Cindy Meister's excellent answer对类似问题为基础，以下面代码为例。

这里的主要概念是确保找到与您的搜索文本匹配的内容 (foundAnotherMatch) 并跟踪找到第一个匹配项的位置 (firstFoundPosition = searchRng.Start)。考虑到这些，您可以遍历文档中的每一个匹配项，然后在到达末尾时停止搜索（实际上，当您绕回并再次回到第一次匹配项时）。

如下所示，每次出现时都会写下您找到的文本。

Option Explicit

Sub ReplaceAndWrite()
    Dim TextFile As Integer
    Dim FilePath As String
    Dim FileName As String
    FileName = ActiveDocument.Name
    FilePath = ActiveDocument.Path & "\" & FileName & ".txt"
    TextFile = FreeFile
    Open FilePath For Output As TextFile
    
    Dim thisDoc As Range
    Dim searchRng As Range
    Set thisDoc = ActiveDocument.Range
    Set searchRng = thisDoc.Duplicate
    
    With searchRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "(#VL-*>) <[! ,^13]@#"
        .Replacement.Text = "\1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
            With .Replacement
                .ClearFormatting
                .Font.Bold = True
                .Font.ColorIndex = wdBlue
                .Font.Underline = True
                .Font.AllCaps = True
            End With
        .MatchCase = False
        
        Dim foundAnotherMatch As Boolean
        Dim firstFoundPosition As Long
        foundAnotherMatch = .Execute
        
        Do While foundAnotherMatch
            Dim foundText As String
            foundText = searchRng.Text
            If firstFoundPosition = 0 Then
                '--- save the location of the first occurrence of the text
                firstFoundPosition = searchRng.Start
            ElseIf firstFoundPosition = searchRng.Start Then
                '--- we're back at the first position (wrapped from the
                '    end of the document), so exit
                Exit Do
            End If
            
            Write #TextFile, foundText
            
            searchRng.Collapse wdCollapseEnd
            foundAnotherMatch = .Execute(Forward:=True)
        Loop
    End With
   
    Close TextFile
End Sub

Answer 2

例如：

Sub Demo()
Application.ScreenUpdating = False
Dim StrOut As String, DocTgt As Document
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "(#[Vv][Ll]-*>) <[! ,^13]@#"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    StrOut = StrOut & .Text & vbCr
    .Text = Split(.Text, " ")(0)
    .Collapse wdCollapseEnd
  Loop
  Set DocTgt = Documents.Add
  DocTgt.Range.Text = StrOut
  DocTgt.SaveAs2 FileName:=Split(.FullName, ".doc")(0) & ".txt", _
    Fileformat:=wdFormatText, AddToRecentFiles:=False
  DocTgt.Close False
End With
Application.ScreenUpdating = True
MsgBox "Found & Saved:" & vbCr & StrOut
End Sub

尚不清楚您是要查找大写字符串还是小写字符串-您的其他线程暗示了后者。因此，我修改了 Find 表达式以查找其中一个。

不清楚是要输出整个找到的字符串，还是只输出保留的位。如果只是后者，交换顺序：

    StrOut = StrOut & .Text & vbCr
    .Text = Split(.Text, " ")(0)