|
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 A jeweils die 10 aufeinanderfolgenden Zeilen verbunden - also Zeile 2-12 verbunden; Zeile 13-23 verbunden etc.In Spalte B jedoch nicht, da ich jeweils eine Emailadresse pro Zeile habe... D.h. ich habe 10 emailadressen drin, an die der Text aus der verbundenen Zelle A 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 :)
Folgend der Code:
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("Please select the due date column:", "KuTools For Excel", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the recipients?email column:", "KuTools For Excel", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "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(r) 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
|