Sicherlich haben Sie in Ihrem Arbeitsalltag schon einmal die Notwendigkeit verspürt, in Microsoft Outlook eine bestehende Ordnerstruktur zu kopieren, ohne die darin enthaltenen E-Mails oder anderen Inhalte mitzukopieren. Dies kann besonders hilfreich sein, wenn Sie für verschiedene Projekte oder regelmäßige Aufgaben eine spezifische Ordnerhierarchie benötigen. Standardmäßig bietet Outlook keine direkte Funktion, um nur die Ordnerstruktur zu replizieren. Hier kommt die Verwendung eines VBA-Makros ins Spiel.
Durch das Schreiben eines einfachen Makros können Sie die gewünschte Funktionalität erreichen: die Möglichkeit, nur die Ordnerstruktur eines Postfachs zu kopieren, ohne die Inhalte der Ordner zu berücksichtigen. Dies spart nicht nur Zeit, sondern auch die manuelle Mühe, die sonst mit dem Neuerstellen komplexer Ordnerstrukturen verbunden wäre. Im Folgenden finden Sie eine Anleitung, wie Sie ein solches Makro erstellen und verwenden können.
- Öffnen Sie den Visual Basic Editor in Outlook: Drücken Sie
Alt + F11in Outlook. - Fügen Sie ein neues Modul hinzu: Gehen Sie im Projekt-Explorer zu Ihrem Outlook-Projekt, klicken Sie mit der rechten Maustaste darauf und wählen Sie
Einfügen > Modul. - Kopieren Sie das folgende Makro in das neue Modul:
Sub CopyFolders()
Dim SourceFolder As Outlook.Folder
Dim TargetFolder As Outlook.Folder
Dim Folder As Outlook.Folder
Set SourceFolder = GetFolder("Wählen Sie den Quellordner aus")
If SourceFolder Is Nothing Then Exit Sub
Set TargetFolder = GetFolder("Wählen Sie den Zielordner aus")
If TargetFolder Is Nothing Then Exit Sub
CopySubFolders SourceFolder, TargetFolder
MsgBox "Ordnerkopie abgeschlossen!", vbInformation
End Sub
Sub CopySubFolders(SourceFolder As Outlook.Folder, TargetFolder As Outlook.Folder)
Dim SubFolder As Outlook.Folder
Dim NewFolder As Outlook.Folder
For Each SubFolder In SourceFolder.Folders
Set NewFolder = TargetFolder.Folders.Add(SubFolder.Name)
CopySubFolders SubFolder, NewFolder
Next SubFolder
End Sub
Function GetFolder(Title As String) As Outlook.Folder
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set GetFolder = objNS.PickFolder
If Not GetFolder Is Nothing Then
MsgBox "Ausgewählter Ordner: " & GetFolder.FolderPath, vbInformation, Title
End If
Set objNS = Nothing
End Function
- Führen Sie das Makro aus: Drücken Sie
Alt + F8, wählen SieCopyFoldersaus der Liste und klicken Sie aufAusführen.
Bitte beachten Sie, dass das Ausführen von Makros Sicherheitsrisiken birgt. Stellen Sie sicher, dass Sie den Code verstehen, bevor Sie ihn ausführen, und dass Ihr Outlook so konfiguriert ist, dass die Ausführung von Makros erlaubt ist. Auch sollten Sie bedenken, dass VBA-Makros nicht auf allen Plattformen (wie Outlook für das Web oder mobile Apps) funktionieren.
Typische Stolperfallen (und Lösungen)
Makros deaktiviert: Datei → Optionen → Trust Center → Einstellungen für das Trust Center → Makroeinstellungen → temporär „Alle Makros aktivieren“ (oder signieren).
Falscher Zielordner gewählt: Wähle als Ziel den übergeordneten Ordner; das Skript legt darunter die gleiche Struktur an.
Sonderzeichen im Ordnernamen: Outlook lässt bestimmte Zeichen nicht zu. Im Regelfall sind vorhandene Namen aber schon gültig; andernfalls bricht
Folders.Addan genau diesem Ordner ab.
Optional: „Root mitkopieren“
Wenn du zusätzlich einen Container mit dem Quellnamen im Ziel anlegen willst, ersetze in CopyFolderStructure diesen Teil:
CopySubtree src, dst
durch:
Dim top As Outlook.MAPIFolder
On Error Resume Next
Set top = dst.Folders(src.Name)
On Error GoTo 0
If top Is Nothing Then Set top = dst.Folders.Add(src.Name)
CopySubtree src, top
So, nun hatte ich mehr erfolg und erfahrung mit den Makros. Ich habe nun eines erstellen lassen (KI), dass immer eine neue Datei im Dokumente-Ordner angelegt wird mit dem Namen des nächsten Jahres (z. B. Archiv 2026.pst), und die gewählte Quellordnerstruktur direkt dort hineinkopiert wird.
Hier ist das fertige Makro, welche einwandfrei bei mir funktioniert:
Option Explicit
Public Sub CopyFolderStructureToNewPST()
Dim src As Outlook.MAPIFolder
Dim ns As Outlook.NameSpace
Dim newRoot As Outlook.MAPIFolder
Dim pstPath As String, nextYear As String, newStoreName As String
Set ns = Application.GetNamespace(„MAPI“)
nextYear = Year(Date) + 1
newStoreName = „Archiv “ & nextYear
pstPath = Environ(„USERPROFILE“) & „\Documents\“ & newStoreName & „.pst“
‚ Quellordner auswählen
Set src = PickFolderEx(„Quellordner auswählen“)
If src Is Nothing Then Exit Sub
‚ Neue PST anlegen und in Outlook einbinden
On Error Resume Next
ns.AddStore pstPath
On Error GoTo 0
‚ Neu hinzugefügten Store finden (meist der letzte in der Liste)
Set newRoot = ns.Folders(ns.Folders.Count)
newRoot.Name = newStoreName
‚ Struktur direkt in die neue PST kopieren
CopySubtree src, newRoot
MsgBox „Neue PST ‚“ & newStoreName & „‚ erstellt und Struktur von“ & vbCrLf & _
src.FolderPath & vbCrLf & „übernommen.“ & vbCrLf & „Datei: “ & pstPath, vbInformation
End Sub
Private Sub CopySubtree(ByVal src As Outlook.MAPIFolder, ByVal dst As Outlook.MAPIFolder)
Dim sf As Outlook.MAPIFolder
Dim newF As Outlook.MAPIFolder
For Each sf In src.Folders
Set newF = Nothing
On Error Resume Next
Set newF = dst.Folders(sf.Name)
On Error GoTo 0
If newF Is Nothing Then
Set newF = dst.Folders.Add(sf.Name)
End If
‚ rekursiv Unterordner anlegen
CopySubtree sf, newF
Next sf
End Sub
Private Function PickFolderEx(ByVal captionText As String) As Outlook.MAPIFolder
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace(„MAPI“)
Set PickFolderEx = ns.PickFolder
If Not PickFolderEx Is Nothing Then
MsgBox „Ausgewählt: “ & PickFolderEx.FolderPath, vbInformation, captionText
End If
End Function
Sry mein Fehler, es hat irgendwie beim Kopieren die falschen Gänsefüsschen genommen. Nun funktioniert es, jedoch ist trotzdem alles in einem unterordner, das manuele verschiedebn meiner ordner ist immernoch notwendig… Ich versuche es selber weiter, sonst 1X im Jahr meine 20 Ordner kurz eine Ebene hochzuschieben ist kein Ding.
DAnke
Ich verwende das Makro in Outlook 365. Leider muss ich die Ordner immer noch etwas manuell verschieben. Denn: Ich wähle eine PST Datei, muss aber beim Zielordner eine Ebene unterhalb wählen, sonst kommt ein Laufzeitfehler. Mache ich etwas falsch? Also ich habe eine PST Datei die heisst 2025 – also alle meine Mails von 2025 werden dorthin verschoben. Ich erstelle eine PST Datei 2026 und will die Struktur 2025 kopieren ich muss jedoch bei 2026 eine Ebene unterhalb wählen mit diesem Makro… Chat GPT konnte mir leider auch nicht weiterhelfen und ich habe 0 Ahnung von Makros, ausser kopieren und ausführen 😉
Danke für die ausführliche Beschreibung!
Du machst nichts falsch, aber das Verhalten, das du beschreibst, liegt an einer kleinen technischen Eigenheit in Outlooks Objektmodell.
Was passiert da genau?
Wenn du eine neue PST-Datei wie „2026“ erstellst, erscheint sie in Outlook als ein Root-Ordner (also ganz oben in der Struktur). Dieser Root-Ordner ist kein richtiger Container für Unterordner, wie es z. B. „Posteingang“ oder „Gesendete Elemente“ sind. Deshalb kann Outlook beim Versuch, dort direkt Unterordner zu erstellen, einen Laufzeitfehler auslösen.
Lösung: Automatisch einen Ziel-Unterordner anlegen
Wir können das Makro so anpassen, dass es erkennt, wenn du einen Root-Ordner wie „2026“ auswählst, und dann automatisch einen Unterordner darin erstellt (z. B. „Strukturkopie“), in den die Ordnerstruktur kopiert wird.
Hier ist die überarbeitete Version des Makros:
Nun habe ich es mit deinem neuen Makro versucht, aber ich erhalte folgende Meldung:
Fehler beim Kompilieren
Syntaxfehler
Versuche es mal hiermit:
Option Explicit
Public Sub CopyFolderStructure()
Dim src As Outlook.MAPIFolder
Dim dst As Outlook.MAPIFolder
Set src = PickFolderEx(„Quellordner auswählen“)
If src Is Nothing Then Exit Sub
Set dst = PickFolderEx(„Zielordner auswählen (übergeordneter Ordner)“)
If dst Is Nothing Then Exit Sub
CopySubtree src, dst
MsgBox „Ordnerstruktur kopiert von:“ & vbCrLf & _
“ “ & src.FolderPath & vbCrLf & „nach:“ & vbCrLf & _
“ “ & dst.FolderPath, vbInformation
End Sub
Private Sub CopySubtree(ByVal src As Outlook.MAPIFolder, ByVal dst As Outlook.MAPIFolder)
Dim sf As Outlook.MAPIFolder
Dim newF As Outlook.MAPIFolder
For Each sf In src.Folders
‚ Ordner ggf. wiederverwenden, wenn er bereits existiert
Set newF = Nothing
On Error Resume Next
Set newF = dst.Folders(sf.Name)
On Error GoTo 0
If newF Is Nothing Then
‚ Ohne 2. Parameter: übernimmt Standard-Itemtyp des Zielcontainers
Set newF = dst.Folders.Add(sf.Name)
End If
‚ Rekursiv Unterordner anlegen
CopySubtree sf, newF
Next sf
End Sub
Private Function PickFolderEx(ByVal captionText As String) As Outlook.MAPIFolder
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace(„MAPI“)
Set PickFolderEx = ns.PickFolder
If Not PickFolderEx Is Nothing Then
‚ Infoausgabe (rein kosmetisch)
MsgBox „Ausgewählt: “ & PickFolderEx.FolderPath, vbInformation, captionText
End If
Set ns = Nothing
End Function