VBA Excel - Outlook Mails auslesen inkl. Unterordner eines Funktionspostfaches - Script anpassen

Set olOrdner = GetObject("", "Outlook.Application").Session.Stores("funktionspostfach@arbeit.com").GetDefaultFolder(6)  

 Set next = Cells(Rows.Count, "A").End(xlUp).Offset(1)  

Sub Outlook_Ordnerliste_Count()
   Dim Ol, mf, Mf1, mf2, Ns, mf3, mf4, mf5, mf6, mf7, i&
   Dim Tb As Worksheet
   Dim VonDatum As Date, BisDatum As Date
   
   On Error Resume Next
   i = Range("A1").Row  

    VonDatum = InputBox("Bitte Datum des ersten zu betrachtenden Tages eingeben:", "Datumseingabe", Format(Now - 1, "DD.MM.YYYY"))  
    BisDatum = InputBox("Bitte Datum des letzten zu betrachtenden Tages eingeben:", "Datumseingabe", Format(Now, "DD.MM.YYYY  23:59:59"))  

   Set Ol = CreateObject("Outlook.Application")  
   Set Ns = Ol.GetNamespace("MAPI") 'Konto einschränken  
   Set Tb = Sheets("Maileingang"): Tb.Cells.ClearContents  
   
    
    For Each mf In Ns.Folders
        Tb.Cells(i, 1).Value = mf.Name: i = i + 1
        Tb.Cells(i - 1, 9) = mf.Items.Count
    
        For Each Mf1 In mf.Folders
        If Mf1.Items.ReceivedTime >= VonDatum And Mf1.Items.ReceivedTime <= BisDatum Then
            Tb.Cells(i, 2).Value = Mf1.Name: i = i + 1
            Tb.Cells(i - 1, 9) = Mf1.Items.Count
        End If
        
            For Each mf2 In Mf1.Folders
            If mf2.Items.ReceivedTime >= VonDatum And mf2.Items.ReceivedTime <= BisDatum Then
                Tb.Cells(i, 3).Value = mf2.Name: i = i + 1
                Tb.Cells(i - 1, 9) = mf2.Items.Count
            End If
            
                For Each mf3 In mf2.Folders
                If mf3.Items.ReceivedTime >= VonDatum And mf3.Items.ReceivedTime <= BisDatum Then
                    Tb.Cells(i, 4).Value = mf3.Name: i = i + 1
                    Tb.Cells(i - 1, 9) = mf3.Items.Count
                End If
                
                    For Each mf4 In mf3.Folders
                    If mf4.Items.ReceivedTime >= VonDatum And mf4.Items.ReceivedTime <= BisDatum Then
                        Tb.Cells(i, 5).Value = mf4.Name: i = i + 1
                        Tb.Cells(i - 1, 9) = mf4.Items.Count
                    End If
                    
                        For Each mf5 In mf4.Folders
                        If mf5.Items.ReceivedTime >= VonDatum And mf5.Items.ReceivedTime <= BisDatum Then
                            Tb.Cells(i, 6).Value = mf5.Name: i = i + 1
                            Tb.Cells(i - 1, 9) = mf5.Items.Count
                        End If
                        
                            For Each mf6 In mf5.Folders
                            If mf6.Items.ReceivedTime >= VonDatum And mf6.Items.ReceivedTime <= BisDatum Then
                                Tb.Cells(i, 7).Value = mf6.Name: i = i + 1
                                Tb.Cells(i - 1, 9) = mf6.Items.Count
                            End If
                            
                                For Each mf7 In mf6.Folders
                                If mf7.Items.ReceivedTime >= VonDatum And mf7.Items.ReceivedTime <= BisDatum Then
                                    Tb.Cells(i, 8).Value = mf7.Name: i = i + 1
                                    Tb.Cells(i - 1, 9) = mf7.Items.Count
                                End If
                            Next
                        Next
                    Next
                Next
            Next
         Next
      Next
    Next
    
   Set Ns = Nothing: Set Mf1 = Nothing: Set mf = Nothing: Set Ol = Nothing: Set Tb = Nothing
   Set mf2 = Nothing: Set mf3 = Nothing

End Sub