Liebe VBA-Freunde,

ich bastle gerade an einem Makro und komme nicht weiter. Ziel ist es, über Excel Mailentwürfe zu erstellen und nur zu speichern (und nicht gleich zu verschicken).

Das Erstellen der passenden Mails funktioniert wunderbar, nur überschreibe ich mit meinem Loop immer die vorherigen Mailentwürfe, sodass ich am Ende nur den letzten habe. Ich würde gern für jeden Eintrag in der Liste einen Entwurf im Entwürfeorder haben. Wenn ich das hintereinander ohne Loop kopiere und Mail1, Mail2 etc. als Object nutze, werden wie gewünscht die Entwürfe erstellt. Nur ändert sich die Liste und den Code jedes Mal zu bearbeiten ist keine Option. Gibt es eine Möglichkeit das mit einem Loop zu lösen?

Vielen Dank!

Liebe Grüße

Johannes

Sub Mailentwürfe_Mitglieder() ' Problem: Überschreibt "Mail" immer wieder

Application.ScreenUpdating = False

    Dim Obj, Mail As Object
    Dim letzteZeile As Integer, Zeile As Integer, SpalteName As Integer
    
    Set Obj = CreateObject("Outlook.Application")
    Set Mail = Obj.CreateItem(0)
    letzteZeile = Range("Daten").Row + Range("Daten").Rows.Count - 1
    SpalteName = Range("Daten_Kopf").Find("Name").Column
    
    For Zeile = Range("Daten").Row To letzteZeile
        Range("Auswahlfeld") = Worksheets("Eingabe").Cells(Zeile, SpalteName)
        With Mail
            .Subject = Range("Mail_Betreff")
            .To = Range("Mail_An")
            .cc = Range("Mail_cc")
        End With
        If Range("Mail_Versandart") = "Mail Standard" Then
            Mail.Body = Range("Mail_Text_Standard")
        Else
            Mail.Body = Range("Mail_Text_weitere_Mitglieder")
        End If
        Mail.Display
        Mail.Save
        Mail.Close 0
      '  Application.Wait (Now + TimeValue("0:00:01"))
      '  Mail.SaveAs "H:\Test\" & "message.htm", 5
      '  Obj.Quit
      '  Application.Wait (Now + TimeValue("0:00:02"))
    Next Zeile
    Set Obj = Nothing
    Set Mail = Nothing

End Sub