Tabellenzeile nach MS Outlook kopieren

Hallo allerseits,

meine Herausforderung:
Jene Zeile einer Excel (2019)-Tabelle, in der ein Doppelklick auf die erste Zelle erfolgt (in der der Name des Empfängers steht), soll in ein Mail (MS Outlook) kopiert werden - die Verknüpfung zwischen dem Namen und der Mailadresse des Empfängers geschieht mittels einer entsprechenden Liste auf einem anderen Tabellenblatt.

Die Felder "An", "Cc", "Betreff" sollen dabei entsprechend ausgefüllt werden, außerdem soll ein kurzer Begleittext mit eingefügt werden.

Da ich mich mit VBA nicht auskenne, hab' ich mir vorerst folgenden Code "ergoogelt":

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Cancel = True

Dim Zeile As Range
Dim MailApp As Object
Dim Mail As Object

' Aktuelle Zeile auswählen
Set Zeile = Selection.EntireRow

' Neue E-Mail erstellen
Set MailApp = CreateObject("Outlook.Application")
Set Mail = MailApp.CreateItem(0)

' Betreff und Inhalt der E-Mail setzen
Mail.Subject = "Tabellenzeile kopiert"
Mail.Body = "Hier ist die kopierte Tabellenzeile:" & vbCrLf & vbCrLf & Zeile.Address

' Tabellenzeile als Tabelle in den E-Mail-Body einfügen
Zeile.Copy
Mail.GetInspector.WordEditor.Range.PasteExcelTable False, False, False

' E-Mail anzeigen
Mail.Display
End If
End SubPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Cancel = True

Dim Zeile As Range
Dim MailApp As Object
Dim Mail As Object

' Aktuelle Zeile auswählen
Set Zeile = Selection.EntireRow

' Neue E-Mail erstellen
Set MailApp = CreateObject("Outlook.Application")
Set Mail = MailApp.CreateItem(0)

' Betreff und Inhalt der E-Mail setzen
Mail.Subject = "Tabellenzeile kopiert"
Mail.Body = "Hier ist die kopierte Tabellenzeile:" & vbCrLf & vbCrLf & Zeile.Address

' Tabellenzeile als Tabelle in den E-Mail-Body einfügen
Zeile.Copy
Mail.GetInspector.WordEditor.Range.PasteExcelTable False, False, False

' E-Mail anzeigen
Mail.Display
End If
End Sub

Unglücklicherweise funktioniert es (noch) nicht ganz, wie es soll:

- Der Zugriff auf das zweite Tabellenblatt mit der Adressenliste fehlt, somit wird das "An" Feld auch nicht ordnungsgemäß ausgefüllt

- Der Betreff wird zwar ausgefüllt, soll aber folgendermaßen abgeändert werden: "YYMMTT (aktuelles Datum)_Matrix_STU"

- Die Tabellenzeile wird zwar wunschgemäß kopiert und eingefügt, aber der Text "Hier ist die kopierte Tabellenzeile:" kommt nicht mit

Kann mir bitte jemand von Euch diesbezüglich weiterhelfen? Ich hab' leider nicht die geringste Idee ...

Vielen herzlichen Dank schon mal vorab!

Grüße, Chris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, sTag As String
  Dim iZeile As Long
  
  If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub
  Cancel = True
  
  sTag = Right$(Date, 2) & Mid$(Date, 4, 2) & Left$(Date, 2)
  iZeile = Target.Row
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")    ' Blatt mit Maildaten
  Set WSh2 = Target.Parent                      ' Datenblatt

  sMailtext = "Hier ist die kopierte Tabellenzeile:" & vbLf
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .Getinspector.Display                     ' Signatur holen und anzeigen
      .Subject = sTag & "_Matrix_STU"           ' Betreff
      .To = WSh1.Range("A" & iZeile).Value      ' Empfänger
      .CC = WSh1.Range("B" & iZeile).Value      ' ggf. Kopie
      .body = sMailtext & .body                 ' Ausgabe mit Signatur
      
      WSh2.Range(Target.EntireRow.Address).Copy ' Bereich kopieren, ganze Zeile
      With .Getinspector.WordEditor.Application.Selection
          .Start = Len(sMailtext)
          .Paste                                ' Bereich in Mail einfügen
      End With
      
  End With

End Sub

Hallo Volti,

habe Deinen Code soeben eingefügt - funktioniert soweit super, Danke! :-)

Auch das Holen der Mailadresse klappt problemlos, ich habe den Namen des zweiten Blattes inkl. der Spalte angepasst:

https://www.herber.de/bbs/user/166703.xlsm

Zum "Feinschliff" hätte ich eben gerne noch die Titelzeile als Überschrift mit dabei ... und lässt der Mailinhalt sich evtl. noch folgendermaßen gestalten?

- Als Anrede bspw. "Hallo Def," (mit dem Vornamen des jeweils gewählten Empfängers aus Spalte B)

_ Leerzeile

- Text "Hier ist Deine persönliche Qualifikationsübersicht:"

- Leerzeile

- Tabellenausschnitt inkl. Titelzeile

- Leerzeile

- Text "Bitte aktualisieren und an mich retournieren!"

- Leerzeile

- Abschiedsfloskel (inkl. Zeilenumbruch)
"Liebe Grüße,
STU"

Nochmals vielen lieben Dank für Deine Bemühungen - ich bin zuversichtlich, dass das so funktionieren wird und werde nach dem Testen auf jeden Fall nochmals berichten ;-)

Viele Grüße,
Chris

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
' Sendet Mail mit integriertem Bereich als Bereich
  Dim WSh As Worksheet
  Dim sBody1 As String, sBody2 As String, sTag As String
  Dim iZeile As Long, i As Integer
  
  iZeile = Cells(Rows.Count, "A").End(xlUp).Row   'Letzte Zeile in $A
  If Intersect(Target, Range("A2:A" & iZeile)) Is Nothing Then Exit Sub
  iZeile = Target.Row
  Cancel = True
  
  Set WSh = ThisWorkbook.Sheets("Mailadressen")     ' Blatt mit Maildaten

  sTag = Right$(Date, 2) & Mid$(Date, 4, 2) & Left$(Date, 2)
  
  sBody1 = "Hallo " & WSh.Range("B" & iZeile).Value & ",¶¶" _
         & "hier ist Deine persönliche Qualifikationsübersicht:¶"
  sBody2 = "Bitte aktualisieren und an mich retournieren!¶¶" _
         & "Liebe Grüße¶STU"
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .Getinspector.Display                         ' Signatur holen und anzeigen
      .Subject = sTag & "_Matrix_STU"               ' Betreff
      .To = WSh.Range("D" & iZeile).Value           ' Empfänger
      .body = Replace(sBody1 & sBody2, "¶", vbLf)   ' Ausgabe ohne Signatur
      
      For i = 0 To 1
          If i = 1 Then ActiveSheet.Rows(1).Copy Else Target.EntireRow.Copy
          With .Getinspector.WordEditor.Application.Selection
              .Start = Len(sBody1) + i              ' Einfügebereich ggf. mit spielen
              .Paste                                ' Bereich in Mail einfügen
          End With
      Next i
  End With

End Sub

Beliebteste Forumthreads (12 Monate)

Tabellenzeile nach MS Outlook kopieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenzeile nach MS Outlook kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread