Zeitsparende Lösungen für Outlook: Automatisiertes Kopieren von Ordnerhierarchien

Outlook VBA

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 + F11 in 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 Sie CopyFolders aus der Liste und klicken Sie auf Ausfü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.Add an 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

Ähnliche Beiträge:

  1. So ändern Sie die Ordnerklasse nach dem Export eines IMAP-Kontos
  2. Wer hat die E-Mail gelesen? Lösungen für gemeinsame Postfächer in Outlook
  3. Von „ANHÄNGE“ zu „GESENDET“: Ein Outlook Makro für strukturierten E-Mail-Versand

-

Vorheriger Artikel Nächster Artikel

1 Stern2 Sterne3 Sterne4 Sterne5 Sterne (1 votes, average: 5,00 out of 5)
Loading...

6 Kommentare zu “Zeitsparende Lösungen für Outlook: Automatisiertes Kopieren von Ordnerhierarchien”

  1. Nahuel

    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

    Antwort ↓
  2. Nahuel

    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

    Antwort ↓
  3. Nahuel

    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 😉

    Antwort ↓
    1. Mailhilfe Artikelautor

      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:

      Sub CopyFolders()
      Dim SourceFolder As Outlook.Folder
      Dim TargetFolder As Outlook.Folder
      Dim RealTargetFolder 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

      ‚ Wenn der Zielordner keine Unterordner enthalten darf, erstelle einen neuen Unterordner
      On Error Resume Next
      Dim Test As Object
      Set Test = TargetFolder.Folders
      If Err.Number <> 0 Then
      Err.Clear
      Set RealTargetFolder = TargetFolder.Parent.Folders.Add(„Strukturkopie“)
      Else
      Set RealTargetFolder = TargetFolder
      End If
      On Error GoTo 0

      CopySubFolders SourceFolder, RealTargetFolder
      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
      Dim ExistingFolder As Outlook.Folder

      For Each SubFolder In SourceFolder.Folders
      On Error Resume Next
      Set ExistingFolder = TargetFolder.Folders(SubFolder.Name)
      On Error GoTo 0

      If ExistingFolder Is Nothing Then
      Set NewFolder = TargetFolder.Folders.Add(SubFolder.Name)
      Else
      Set NewFolder = ExistingFolder
      End If

      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

      Antwort ↓
      1. Ferrari

        Nun habe ich es mit deinem neuen Makro versucht, aber ich erhalte folgende Meldung:

        Fehler beim Kompilieren

        Syntaxfehler

        Antwort ↓
        1. Mailhilfe Artikelautor

          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

          Antwort ↓

Schreibe einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht. Erforderliche Felder sind mit * markiert