Ich habe mich verschrieben, hier nochmal:

Makro 2: Funktioniert für mehrere markierte Mails

Sub CopyAndMoveEmails()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olSelection As Outlook.Selection
    Dim destFolderName As String
    Dim destFolder As Outlook.folder
    Dim receivedFolder As Outlook.folder
    Dim mailItem As Object
    Dim i As Integer

    ' Initialize Outlook objects
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olSelection = olApp.ActiveExplorer.Selection

    ' Prompt user for destination folder name
    destFolderName = InputBox("Enter the name of the destination folder:", "Destination Folder")

    ' Check if user input is empty
    If destFolderName = "" Then
        MsgBox "No destination folder specified.", vbExclamation
        Exit Sub
    End If

    ' Find the destination folder
    Set destFolder = FindFolder(olNamespace.folders, destFolderName)

    If destFolder Is Nothing Then
        MsgBox "The destination folder """ & destFolderName & """ does not exist.", vbExclamation
        Exit Sub
    End If

    ' Find the "_01_erhalten" folder
    Set receivedFolder = FindFolder(olNamespace.folders, "_01_erhalten")

    If receivedFolder Is Nothing Then
        MsgBox "The folder ""_01_erhalten"" does not exist.", vbExclamation
        Exit Sub
    End If

    ' Process each selected email
    For i = 1 To olSelection.Count
        If TypeOf olSelection.Item(i) Is Outlook.mailItem Then
            Set mailItem = olSelection.Item(i)
            ' Copy the email to the destination folder
            On Error Resume Next
            mailItem.Copy.Move destFolder
            If Err.Number <> 0 Then
                MsgBox "Error copying email: " & Err.Description, vbExclamation
                Exit Sub
            End If
            On Error GoTo 0

            ' Move the original email to the "_01_erhalten" folder
            On Error Resume Next
            mailItem.Move receivedFolder
            If Err.Number <> 0 Then
                MsgBox "Error moving email: " & Err.Description, vbExclamation
                Exit Sub
            End If
            On Error GoTo 0
        End If
    Next i

    ' Display success message
    MsgBox "Emails copied to """ & destFolderName & """ and moved to ""_01_erhalten"" successfully.", vbInformation
End Sub

Function FindFolder(parentFolders As Outlook.folders, folderName As String) As Outlook.folder
    Dim folder As Outlook.folder
    Dim subFolder As Outlook.folder

    On Error Resume Next
    ' Iterate through each folder to find the matching folder
    For Each folder In parentFolders
        If folder.Name = folderName Then
            Set FindFolder = folder
            Exit Function
        Else
            Set subFolder = FindFolder(folder.folders, folderName)
            If Not subFolder Is Nothing Then
                Set FindFolder = subFolder
                Exit Function
            End If
        End If
    Next folder
    On Error GoTo 0

    ' If not found, return Nothing
    Set FindFolder = Nothing
End Function

VG, Kisska