Option Explicit

Sub GetAddresses()
'Graham Mayor - https://www.gmayor.com - Last updated - 01 Apr 2020 
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        ProcessFolder olFolder
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
            DoEvents
        Next SubFolder
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Set cFolders = Nothing
    Set olNS = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Private Sub ProcessFolder(iFolder As Folder)
'Graham Mayor - https://www.gmayor.com - Last updated - 01 Apr 2020 
Const strWB As String = "D:\Path\WorkbookName.xlsx"    'the path to the workbook (which must exist)
Const strSheet As String = "Sheet1"
Dim i As Long
Dim olItem As Object
Dim strSender As String
    If iFolder.items.Count > 0 Then
        For i = 1 To iFolder.items.Count
            Set olItem = iFolder.items(i)
            If TypeName(olItem) = "MailItem" Then
                strSender = Replace(olItem.sender, "'", "")
                strSender = Replace(strSender, Chr(34), "")
                WriteToWorksheet strWB, strsheet, strSender & "', '" & olItem.SenderEmailAddress
                DoEvents
            End If
        Next i
    End If
lbl_Exit:
    Set olItem = Nothing
    Exit Sub
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
                                 strRange As String, _
                                 strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function