Outlook naar Excel, niet werkend voor subfolders

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Object
Dim i As Integer
Dim olDict As Dictionary
Set olDict = New Scripting.Dictionary
Dim olDict2 As Dictionary
Set olDict2 = New Scripting.Dictionary

Set OutlookApp = New Outlook.Application

LastRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row

    ' let the user choose which account to use
    Set myAccounts = OutlookApp.GetNamespace("MAPI").Stores
    'myAccounts.AddItemOutlookNamespace.GetDefaultFolder (olFolderInbox)
    For i = 1 To myAccounts.Count
        res = MsgBox(myAccounts.Item(i).DisplayName & "?", vbYesNo)
        If res = vbYes Then
            Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)
            Exit For
        End If
    Next
    If myInbox Is Nothing Then Exit Sub ' avoid error if no account is chosen
    

    Dim key As Range: Set key = Sheets(1).Range("A4")
    While Not IsEmpty(key)
        If olDict2.Exists(key.Value) Then
            Set olDict2(key.Value) = olDict2(key.Value) + key.Offset(ColumnOffset:=2)
        Else
            olDict2.Add key.Value, key.Offset(ColumnOffset:=2)
        End If
        Set key = key.Offset(RowOffset:=1)
    Wend

'To access a subfolder (level-1) or a subfolder (level-2). Code found online, not sure how to use it in the box to collect input
'For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders
'    If VBA.UCase(Folder.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then GoTo Label_Folder_Found
'    For Each sFolders In Folder.Folders
'        If VBA.UCase(sFolders.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then
'            Set Folder = sFolders
'            GoTo Label_Folder_Found
'        End If
'    Next sFolders
' Next Folder
    
For Each OutlookMail2 In myInbox.Items
If IsIn(Left(OutlookMail2.Subject, 4), "FW: ,RE: ") Then
OutlookMail2.Subject = Mid(OutlookMail2.Subject, 5)
End If

If olDict.Exists(OutlookMail2.Subject & OutlookMail2.SenderName) Then
    If OutlookMail2.ReceivedTime < olDict(OutlookMail2.Subject & OutlookMail2.SenderName) Then
    Set olDict(OutlookMail2.Subject & OutlookMail2.SenderName) = OutlookMail2.ReceivedTime
    End If
Else:
olDict.Add OutlookMail2.Subject & OutlookMail2.SenderName, OutlookMail2.ReceivedTime
End If
Next OutlookMail2


    
i = 1
For Each OutlookMail In myInbox.Items
If IsIn(Left(OutlookMail.Subject, 4), "FW: ,RE: ") Then
OutlookMail.Subject = Mid(OutlookMail.Subject, 5)
End If
If TypeName(OutlookMail) = "MailItem" And OutlookMail.ReceivedTime >= Range("From_date").Value Then
    If olDict.Exists(OutlookMail.Subject & OutlookMail.SenderName) And Not olDict2.Exists(OutlookMail.Subject & OutlookMail.SenderName) Then
    'if the subject exists test to see which message is newer
        If OutlookMail.ReceivedTime = olDict(OutlookMail.Subject & OutlookMail.SenderName) Then
                Range("A" & LastRow).Offset(i, 0).Value = OutlookMail.Subject & OutlookMail.SenderName
                Range("B" & LastRow).Offset(i, 0).Value = OutlookMail.Subject
                Range("C" & LastRow).Offset(i, 0).Value = OutlookMail.ReceivedTime
                Range("D" & LastRow).Offset(i, 0).Value = OutlookMail.SenderName
                Range("E" & LastRow).Offset(i, 0).Value = OutlookMail.Body
                Range("F" & LastRow).Offset(i, 0).Value = OutlookMail.Categories
        
        i = i + 1
        End If
    End If
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Set olDict = Nothing
End Sub

'

IsIn(