VBATools

Można użyć darmowego programu CodeTwo Outlook Export i zapisać adresu do pliku, który następnie otworzyć plik Excelem i filtrując wyeksportowane adresy.

Jednakże czasem nie można nic instalować i jedynym rozwiązaniem jest makro.

Uruchomić go można w developerze VBA (Alt+F11) w sekcji module.
Jeśli nie ma się doświadczenia polecam przeczytać artykuł Instalacja i uruchamianie makr.

Oczywiście dla wielkich obszarów makro to będzie wykonywać się długo. .. aż do komunikatu ukończenia exportu.
Realizacja jego jest na podstawie zaznaczonych wiadomości (tak jest ono bardziej uniwersalne), a zaznaczenie wszystkich wiadomości realizuje się po przez (Alt+A).

Option Explicit

Sub Zapisz_adresy_email_dla_zaznaczonych_wiadomosci_zawierajace_tresc()
'MVP OShon from VBATools.pl
If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Sub
Dim oMailItem As MailItem
Dim oRecipients As Recipients
Dim oRecipient As Recipient
Dim item As MailItem

Dim MailAdres, oReply, oRecipients2, oRecip
Dim adresy$, adres$, zgoda$
Dim NoDupes As New Collection
Dim I&, J&, Swap1, Swap2, slowo$, plik$
plik = "c:Tempadresy.txt"

slowo = LCase(InputBox("Podaj treść jaka powinna znajdować się w pobranych adresach email", _
 "Podaj część szukanego adresu"))
If Len(slowo) = 0 Then _
 MsgBox "Brak danych wyszukania", vbCritical, " Informacja o błędzie": Exit Sub

On Error Resume Next
For I = 2 To UBound(Split(plik, ""))
 MkDir Split(plik, "")(I - 1)
Next I

For Each item In Application.ActiveExplorer.Selection
DoEvents
 Set MailAdres = item
 Set oReply = item.Reply
 Set oRecipients2 = oReply.Recipients

'adresy DO
 For Each oRecip In oRecipients2
 NoDupes.Add LCase(oRecip.Address)
 Next oRecip
'adresy DW
 For I = 1 To MailAdres.Recipients.Count
 NoDupes.Add LCase(MailAdres.Recipients(I).Address)
 Next I

 If Not MailAdres Is Nothing Then Set MailAdres = Nothing
 If Not oReply Is Nothing Then Set oReply = Nothing
 If Not oRecipients2 Is Nothing Then Set oRecipients2 = Nothing
Next item

On Error GoTo ErrMessage
 For I = 1 To NoDupes.Count - 1
 DoEvents
 For J = I + 1 To NoDupes.Count
 If NoDupes(I) > NoDupes(J) Then
 Swap1 = NoDupes(I)
 Swap2 = NoDupes(J)
 NoDupes.Add Swap1, Before:=J
 NoDupes.Add Swap2, Before:=I
 NoDupes.Remove I + 1
 NoDupes.Remove J + 1
 End If
 Next J
 Next I

 Set oMailItem = Application.CreateItem(olMailItem)
 Set oRecipients = oMailItem.Recipients

 adres = ""
 If FileExists(plik) = False Then
 Open "C:Tempadresy.txt" For Output As #1
 Else
 Open "C:Tempadresy.txt" For Append As #1
 zgoda = MsgBox("Plik " & plik & " istnieje" & _
 vbCr & "Czy dodać adresy do istniejącego pliku?", _
 vbMsgBoxSetForeground + vbQuestion + vbYesNo, " Export adresów")
 If zgoda = vbNo Then MsgBox "Przerwanie operacji ", vbInformation: Exit Sub
 End If
 For J = 1 To NoDupes.Count
 DoEvents
 If adres = NoDupes(J) Then GoTo nastepny
 If NoDupes(J) Like "*" & slowo Or _
 NoDupes(J) Like slowo & "*" Or _
 NoDupes(J) Like "*" & slowo & "*" Then _
 Print #1, NoDupes(J)
 adres = NoDupes(J)
nastepny:
 Next J
 Close #1
 If FileLen(plik) = 0 Then
 Kill plik
 MsgBox "Brak adresów zawierających: " & slowo, vbInformation, " Informacja dodatkowa VBATools.pl"
 Else
 MsgBox "Adresy email z zaznaczonych wiadomości zostały zapisane w pliku " & plik, _
        vbInformation, " Informacja dodatkowa"
 End If
ErrExit:
On Error Resume Next
 If Not oMailItem Is Nothing Then Set oMailItem = Nothing
 If Not oRecipients Is Nothing Then Set oRecipients = Nothing

Exit Sub
ErrMessage:
MsgBox "Błąd procedury " & Err.Number & vbCr _
 & Err.Description, vbExclamation, " Informacja o błędzie"
GoTo ErrExit
End Sub
Private Function FileExists(FilePath As String) As Boolean
On Error GoTo blad
 FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
Exit Function
blad:
FileExists = False
End Function

(c) Shon Oskar – www.VBATools.pl