Wir sprechen hier von ca 1 1/2 Minuten bei 300+ verschachtelten Ordnern. Das ist immer noch hilfreich, wenn man überhaupt nicht weiß, wo was eingeordnet ist, aber eigentlich unreträglich langsam...

Der Code sieht folgendermaßen aus:
 

Public Sub Ordnersuche()
  ' ...
  ' m_Find, SubFolder, etc. kommen aus einem Form
  m_Find = LCase$(m_Find)
  m_Find = Replace(m_Find, "%", "*")
  m_Wildcard = (InStr(m_Find, "*"))

  'Set Folders = Application.Session.Folders
  If Not SubFolder = "" Then
    FullFolderPath = SearchFolderPath & "\" & SubFolder
  Else
    FullFolderPath = SearchFolderPath
  End If
  
  Set Folders = GetFolderPath(FullFolderPath).Folders
  LoopFolders Folders, 0

  If Not m_Folder Is Nothing Then
  ' Hier wird dann weiteres mit dem gefundenen Ordnerelement angestellt
  ' ...
End Sub

' ----------------------------------------------

Private Sub LoopFolders(Folders As Outlook.Folders, Level As Integer)
  Dim F As Outlook.MAPIFolder
  Dim Found As Boolean
  
  For Each F In Folders
    
    If m_Wildcard Then
      Found = (LCase$(F.Name) Like m_Find)
    Else
      Found = (LCase$(F.Name) = m_Find)
    End If
    
    If Not Found Then
      Found = (Replace(LCase$(F.Name), ".", vbNullString) Like Replace(m_Find, ".", vbNullString))
    End If

    If Found Then
      If StopAtFirstMatch = False Then
        If MsgBox("Gefunden: " & vbCrLf & F.Name & vbCrLf & vbCrLf & "Verwenden?", vbQuestion Or vbYesNo) = vbNo Then
          Found = False
        End If
      End If
    End If
    If Found Then
      Set m_Folder = F
      Exit For
    Else
      LoopFolders F.Folders, (Level + 1)
      If Not m_Folder Is Nothing Then Exit For
    End If
  Next
End Sub

' ---------------------------------

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
        
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
        
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function