title: Using Multiple wildcard searches in Word 2007 with VBA
body: <p>I have VBA code that runs through a document and identifies acronyms using wildcards and places them in a separate word document.  Some of my writers don't always follow the proper style guides for acronyms so I'm running four different scripts to find all the possible acronyms.  It's time consuming and I end up with multiple documents. Is there a method to run multiple searches from one script and have all the results placed in the separate document. Truth in Advertising: I found this script on the 'net, but I've been playing with it to attempt to make it do some other features.  Adding current script: </p>
  
  <pre><code>Sub ExtractVariousValuesACRONYMSToNewDocument()
  
  'The macro creates a new document,
  'finds all words consisting of 2 or more uppercase letters
  'in the active document and inserts the words
  'in column 1 of a 3-column table in the new document
  'Each acronym is added only once
  'Use column 2 for definitions
  'Page number of first occurrence is added by the macro in column 3
  
  'Minor adjustments are made to the styles used
  'You may need to change the style settings and table layout to fit your needs
  '=========================
  
  Dim oDoc_Source As Document
  Dim oDoc_Target As Document
  Dim strListSep As String
  Dim strAcronym As String
  Dim oTable As Table
  Dim oRange As Range
  Dim n As Long
  Dim strAllFound As String
  Dim Title As String
  Dim Msg As String
  
  Title = "Extract Acronyms to New Document"
  
  'Show msg - stop if user does not click Yes
  Msg = "This macro finds all words consisting of 2 or more " &amp; _
      "uppercase letters and extracts the words to a table " &amp; _
      "in a new document where you can add definitions." &amp; vbCr &amp; vbCr &amp; _
      "Do you want to continue?"
  
  If MsgBox(Msg, vbYesNo + vbQuestion, Title) &lt;&gt; vbYes Then
      Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  'Find the list separator from international settings
  'May be a comma or semicolon depending on the country
  strListSep = Application.International(wdListSeparator)
  
  'Start a string to be used for storing names of acronyms found
  strAllFound = "#"
  
  Set oDoc_Source = ActiveDocument
  
  'Create new document for acronyms
  Set oDoc_Target = Documents.Add
  
  With oDoc_Target
      'Make sure document is empty
      .Range = ""
  
      'Insert info in header - change date format as you wish
      .PageSetup.TopMargin = CentimetersToPoints(3)
      .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
          "Acronyms extracted from: " &amp; oDoc_Source.FullName &amp; vbCr &amp; _
          "Created by: " &amp; Application.UserName &amp; vbCr &amp; _
          "Creation date: " &amp; Format(Date, "MMMM d, yyyy")
  
      'Adjust the Normal style and Header style
      With .Styles(wdStyleNormal)
          .Font.Name = "Arial"
          .Font.Size = 10
          .ParagraphFormat.LeftIndent = 0
          .ParagraphFormat.SpaceAfter = 6
      End With
  
      With .Styles(wdStyleHeader)
          .Font.Size = 8
          .ParagraphFormat.SpaceAfter = 0
      End With
  
      'Insert a table with room for acronym and definition
      Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
      With oTable
          'Format the table a bit
          'Insert headings
          .Range.Style = wdStyleNormal
          .AllowAutoFit = False
  
          .Cell(1, 1).Range.Text = "Acronym"
          .Cell(1, 2).Range.Text = "Definition"
          .Cell(1, 3).Range.Text = "Page"
          'Set row as heading row
          .Rows(1).HeadingFormat = True
          .Rows(1).Range.Font.Bold = True
          .PreferredWidthType = wdPreferredWidthPercent
          .Columns(1).PreferredWidth = 20
          .Columns(2).PreferredWidth = 70
          .Columns(3).PreferredWidth = 10
      End With
  End With
  
  With oDoc_Source
      Set oRange = .Range
  
      n = 1 'used to count below
  
      With oRange.Find
          'Use wildcard search to find strings consisting of 2 or more uppercase letters
          'Set the search conditions
          'NOTE: If you want to find acronyms with e.g. 2 or more letters,
          'change 3 to 2 in the line below
          .Text = "&lt;[A-Z]{2" &amp; strListSep &amp; "}&gt;"
          .Forward = True
          .Wrap = wdFindStop
          .Format = False
          .MatchCase = True
          .MatchWildcards = True
  
          'Perform the search
          Do While .Execute
              'Continue while found
              strAcronym = oRange
              'Insert in target doc
  
              'If strAcronym is already in strAllFound, do not add again
              If InStr(1, strAllFound, "#" &amp; strAcronym &amp; "#") = 0 Then
                  'Add new row in table from second acronym
                  If n &gt; 1 Then oTable.Rows.Add
                  'Was not found before
                  strAllFound = strAllFound &amp; strAcronym &amp; "#"
  
                  'Insert in column 1 in oTable
                  'Compensate for heading row
                  With oTable
                      .Cell(n + 1, 1).Range.Text = strAcronym
                      'Insert page number in column 3
                      .Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
                  End With
  
                  n = n + 1
              End If
          Loop
      End With
  End With
  
  'Sort the acronyms alphabetically - skip if only 1 found
  If n &gt; 2 Then
      With Selection
          .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
              :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
  
          'Go to start of document
          .HomeKey (wdStory)
      End With
  End If
  
  Application.ScreenUpdating = True
  
  'If no acronyms found, show msg and close new document without saving
  'Else keep open
  If n = 1 Then
      Msg = "No acronyms found."
      oDoc_Target.Close savechanges:=wdDoNotSaveChanges
  Else
      Msg = "Finished extracting " &amp; n - 1 &amp; " acronymn(s) to a new document."
  End If
  
  MsgBox Msg, vbOKOnly, Title
  
  'Clean up
  Set oRange = Nothing
  Set oDoc_Source = Nothing
  Set oDoc_Target = Nothing
  Set oTable = Nothing
  
  End Sub
  </code></pre>