Microsoft Office Forums - View Single Post - [Solved] Find paragraph matching an expression in Word and exporting to Excel spreadsheet

macropod · 11-04-2017, 05:17 AM

Try the following Excel macro. It assumes the 'find' list is in column A of Sheet1 and, if you're using wildcards for a particular Find expression, you'll have TRUE in column B on that row.

The macro includes a folder browser, so all you need do is run the macro and select the folder to process. The macro will add a new sheet and output all matches it finds on that sheet.

You will need to set a Reference to the Microsoft Word Object Library in the Excel VBE.

Code:

Sub DataFind()
Application.ScreenUpdating = False
Dim strFolder As String
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub

Dim strFile As String, strFnd As String, strOut As String
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = True

Dim xlShtIn As Worksheet, xlShtOut As Worksheet, i As Long, j As Long
'Define Data sheet & create & initialize the output sheet
Set xlShtIn = Sheets("Sheet1"): Set xlShtOut = Sheets.Add: j = 1
xlShtOut.Range("A1").Value = "Document"
xlShtOut.Range("B1").Value = "Operator"
xlShtOut.Range("C1").Value = "Text"

'Process each document in the folder
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    'Process each word from the list in the source sheet
    For i = 2 To xlShtIn.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
      strFnd = xlShtIn.Range("A" & i)
      With .Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Text = strFnd
          .MatchWildcards = (xlShtIn.Range("B" & i) = True)
          .Forward = True
          .Wrap = wdFindStop
          .Format = False
          .Execute
        End With
        'Send the matches to the output sheet
        Do While .Find.Found
          j = j + 1
          xlShtOut.Range("A" & j).Value = strFile
          xlShtOut.Range("B" & j).Value = strFnd
          xlShtOut.Range("C" & j).Value = Replace(Split(.Paragraphs(1).Range.Text, vbCr)(0), vbTab, " ")
          .Start = .Paragraphs(1).Range.End
          .Find.Execute
        Loop
      End With
    Next i
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend

' Release object memory
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlShtIn = Nothing: Set xlShtOut = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function