You can do that with a small modification e.g. as follows. Put the messages to be searched in an Outlook folder, select the folder from the macro prompt and the function will search the messages in that folder for whatever xxxxxx is and adds unique items to a collection. You can then write the items in that collection to your worksheet in place of Debug.Print
Option Explicit
Sub ExtractData()
Dim olFolder As Folder
Dim olMsg As Object
Dim Coll As Collection
Dim strData As String
Dim lngCol As Long
Set olFolder = Session.PickFolder
Set Coll = New Collection
For Each olMsg In olFolder.Items
If TypeName(olMsg) = "MailItem" Then
On Error Resume Next
strData = GetData(olMsg)
If Not strData = "" Then
Coll.Add strData, strData
End If
End If
Next olMsg
'write the items in the collection to your worksheet here
For lngCol = 1 To Coll.Count
Debug.Print Coll(lngCol)
Next lngCol
lbl_Exit:
Set olFolder = Nothing
Set olMsg = Nothing
Set Coll = Nothing
Exit Sub
End Sub
Private Function GetData(olItem As Object) As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strData As String
On Error Resume Next
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:="We were unable to approve because * is invalid", MatchWildcards:=True)
strData = oRng.Text
strData = Replace(strData, "We were unable to approve because ", "")
strData = Replace(strData, " is invalid", "")
'do something with strdata e.g.
GetData = strData
Exit Do
Loop
End With
End With
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set olItem = Nothing
Exit Function
End Function