VBA-Archivierungstool für Outlook

So richtest du es ein:
1. Drücke in Outlook ALT + F11, um den VBA-Editor zu öffnen.

2. Gehe auf Einfügen -> Modul und kopiere den Code oben hinein.

3. Speichere und schließe das Fenster.

4.Du kannst das Makro nun über ALT + F8 starten oder dir einen Button oben in die Menüleiste legen.

Sub ArchivierenMitAuswahl()
    Dim objNS As Outlook.NameSpace
    Dim sourceFolder As Outlook.MAPIFolder
    Dim archiveFolder As Outlook.MAPIFolder
    Dim i As Integer
    Dim archivListe As String
    Dim wahl As String
    Dim gesamtZaehler As Long
    
    Set objNS = Application.GetNamespace("MAPI")
    gesamtZaehler = 0
    
    ' 1. Archive auflisten
    archivListe = "Verfügbare Ziele:" & vbCrLf
    For i = 1 To objNS.Folders.Count
        archivListe = archivListe & i & ": " & objNS.Folders.Item(i).Name & vbCrLf
    Next i
    
    ' 2. Nummer abfragen
    wahl = InputBox(archivListe & vbCrLf & "Bitte die Nummer des Ziel-Archivs eingeben:", "Archiv-Auswahl")
    If wahl = "" Then Exit Sub
    
    On Error Resume Next
    Set archiveFolder = objNS.Folders.Item(CInt(wahl))
    On Error GoTo 0
    
    If archiveFolder Is Nothing Then Exit Sub
    
    ' 3. Quelle festlegen (Posteingangsebene)
    Set sourceFolder = objNS.GetDefaultFolder(olFolderInbox).Parent
    
    ' 4. Start der Routine mit Zähler-Übergabe
    ProcessFolderFinal sourceFolder, archiveFolder, gesamtZaehler
    
    ' 5. Abschluss-Dialog mit der Anzahl der Mails
    MsgBox "Archivierung in '" & archiveFolder.Name & "' abgeschlossen!" & vbCrLf & vbCrLf & _
           "Es wurden insgesamt " & gesamtZaehler & " E-Mails verschoben.", vbInformation, "Erfolg"
End Sub

Sub ProcessFolderFinal(ByVal source As Outlook.MAPIFolder, ByVal target As Outlook.MAPIFolder, ByRef zaehler As Long)
    Dim subFolder As Outlook.MAPIFolder
    Dim destFolder As Outlook.MAPIFolder
    Dim i As Long
    
    ' Mails verschieben und zählen
    For i = source.Items.Count To 1 Step -1
        source.Items(i).Move target
        zaehler = zaehler + 1 ' Jede Mail wird gezählt
        
        If i Mod 50 = 0 Then
            DoEvents 
        End If
    Next i
    
    ' Ordner spiegeln
    For Each subFolder In source.Folders
        If subFolder.Name <> "Gelöschte Elemente" And subFolder.Name <> "Gesendete Elemente" And _
           subFolder.Name <> "Junk-E-Mail" And subFolder.Name <> "Postausgang" Then
            
            Set destFolder = Nothing
            On Error Resume Next
            Set destFolder = target.Folders(subFolder.Name)
            On Error GoTo 0
            
            If destFolder Is Nothing Then
                Set destFolder = target.Folders.Add(subFolder.Name)
            End If
            
            ' Rekursiver Aufruf mit Zähler
            ProcessFolderFinal subFolder, destFolder, zaehler
        End If
    Next subFolder
End Sub

Wie du das Makro jetzt benutzt:

1. Drücke ALT + F8 in Outlook.

2. Wähle ArchivierenMitAuswahl und klicke auf Ausführen.

3. Tippe im Fenster die Nummer deines Archivs (z.B. für archiv2026.pst) ein.

4. Bestätige mit "Ja".