Outlook Ordnerauflistung beschleunigen

Sub OutlookDurchsuchen()
Dim N As Namespace
Dim a As Account
Dim S As Store
Dim F
Dim SF
Dim item
Dim Wert
Dim v, x, y, z As String
Dim b As Long
Dim wkb As Workbook
Dim ws As Worksheet
Set wkb = ThisWorkbook
Set ws = wkb.Worksheets(1)
b = 6
Const SD As String = "send"
Const ST As String = "Sent"
Set N = GetNamespace("MAPI")
'        Debug.Print String(40, "-")
'        Debug.Print "Anzahl accounts: " & N.Accounts.Count
'    For Each A In N.Accounts
'        'Debug.Print A.DisplayName, A.CurrentUser.Name
'    Next
For Each F In N.Folders
For Each SF In F.Folders
i = 1
For Each item In SF.Items
If InStr(SF.Name, SD) > 0 Or InStr(SF.Name, ST) > 0 Then
With ws
On Error Resume Next
.Cells(b, 3) = F.Name
.Cells(b, 4) = SF.Name
.Cells(b, 6) = item
If item.Attachments.Count > 0 Then
.Cells(b, 7) = item.Attachments.item(1).Filename
End If
b = b + 1
End With
End If
Next
For Each SSF In SF.Folders
For Each Wert In SSF.Items
If InStr(SSF.Name, SD) > 0 Or InStr(SSF.Name, ST) > 0 Then
With ws
On Error Resume Next
.Cells(b, 3) = F.Name
.Cells(b, 4) = SF.Name
.Cells(b, 5) = SSF.Name
.Cells(b, 6) = Wert
If item.Attachments.Count > 0 Then
.Cells(b, 7) = Wert.Attachments.item(1).Filename
End If
.Cells(b, 8) = "SF"
b = b + 1
End With
End If
Next
Next
Next
Next
End Sub