Thema Datum  Von Nutzer Rating
Antwort
Rot Excel Makro umschreiben
04.07.2019 10:30:37 Ibrakan
NotSolved
04.07.2019 11:29:52 Gast71726
NotSolved
04.07.2019 11:49:24 ibrakan
NotSolved
04.07.2019 12:14:20 Gast6185
NotSolved
04.07.2019 12:56:11 ibrakan
NotSolved

Ansicht des Beitrags:
Von:
Ibrakan
Datum:
04.07.2019 10:30:37
Views:
57
Rating: Antwort:
  Ja
Thema:
Excel Makro umschreiben

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst genau und ausführlich
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
  • Bitte markieren Sie Ihre Anfrage als erledigt wenn Ihnen geholfen wurde
Thema: Name: Email:

 
 

Thema Datum  Von Nutzer Rating
Antwort
Rot Excel Makro umschreiben
04.07.2019 10:30:37 Ibrakan
NotSolved
04.07.2019 11:29:52 Gast71726
NotSolved
04.07.2019 11:49:24 ibrakan
NotSolved
04.07.2019 12:14:20 Gast6185
NotSolved
04.07.2019 12:56:11 ibrakan
NotSolved