Themabewertung:
  • 0 Bewertung(en) - 0 im Durchschnitt
  • 1
  • 2
  • 3
  • 4
  • 5
VBA MAKRO - Email an mehrere Personen/Adressen
#1
Hallo Zusammen,
 
habe null Ahnung von Makros schreiben oder dergleichen ^^. habe mir aber einen Code zusammengebastelt, der bis auf einen Punkt einwandfrei läuft.
Unzwar habe ich in Spalte D jeweils die 10 aufeinanderfolgenden Zeilen verbunden - also Zeile 2-12 verbunden; Zeile 13-23 verbunden etc.In Spalte E jedoch nicht, da ich jeweils eine Emailadresse pro Zeile habe... D.h. ich habe max.10 emailadressen drin, an die der Text aus der verbundenen Zelle D 2 rein soll...
Mein jetziger code schreibt aber immer nur an den ersten emailempfänger.
Für Hilfe wäre ich sehr dankbar - und nochmals - habe null ahnung - daher wäre es toll, wenn ich die antwort einfach reinkopieren könnte Smile

Hab das Thema hier auch noch wo anders aufgeführt:

http://www.vba-forum.de/Forum/View.aspx?...mschreiben

Folgend der Code:

Zitat:Public Sub CheckAndSendMail()
'Updated by Extendoffice 2018/11/22
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim i As Long
    On Error Resume Next
    Set xRgDate = Application.InputBox("Bitte Spalte mit Fälligkeitsdatum auswählen:", "KuTools For Excel", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgSend = Application.InputBox("Bitte Spalte mit Empfänger auswählen:", "KuTools For Excel", , , , , , 8)
    If xRgSend Is Nothing Then Exit Sub
    Set xRgText = Application.InputBox("Bitte Spalte mit Aufgabe auswählen:", "KuTools For Excel", , , , , , 8)
    If xRgText Is Nothing Then Exit Sub
    xLastRow = xRgDate.Rows.Count
    Set xRgDate = xRgDate(1)
    Set xRgSend = xRgSend(1)
    Set xRgText = xRgText(1)
    Set xOutApp = CreateObject("Outlook.Application")
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then
        If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(i - 1).Value
            xMailSubject = "Erinnerung ToDO Liste"
            vbCrLf = "<br><br>"
            xMailBody = "<HTML><BODY>"
            xMailBody = xMailBody & "Sehr geehrte® Herr/Frau " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Erinnerung ToDo Liste - Aufgabenbeschreibung: " & xRgText.Offset(i - 1).Value & vbCrLf
            xMailBody = xMailBody & "Dies ist eine automatisch generierte E-Mail, bitte nicht drauf Antworten"
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    End If
    Next
    Set xOutApp = Nothing
End Sub


Im Anhang Screenshots aus tabelle und mail


Angehängte Dateien Thumbnail(s)
       
Zitieren


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste




Hinweis auf Angebot Excel-Inside - lang    Keine Lösung gefunden? Du kannst Dich gerne an unser erfahrenes Experten-Team wenden um dein Anliegen zu besprechen.
   Gerne erstellen wir auf dieser Basis ein Angebot.
   Sende deine Anfrage einfach
per E-Mail an anfrage@excel-inside.de


Powerd and supported by Excel-InsideSolutions