|
Versuch mal das hier:
Ungetestet. Ob das deiner Vorstellung entspricht, weiss ich nicht.
Sub SendEmailWithExcelData()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim ws As Worksheet
Dim EmailBody As String
Dim FilteredRow As Range
Dim i As Integer, j As Integer
Dim olInspector As Object
' Set the active sheet
Set ws = ActiveSheet
' Find the filtered row
On Error Resume Next
Set FilteredRow = ws.Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
' Check if only one row is visible
If Not FilteredRow Is Nothing Then
If FilteredRow.Count = 1 Then
' Build the email body with an HTML table
EmailBody = "<html><body><table border='1'>"
' Add headers to the table
EmailBody = EmailBody & "<tr><th>ws.Cells(2, 2).Value</th>"
For i = 9 To 15 ' I2:O2 corresponds to columns 9 to 15
EmailBody = EmailBody & "<th>" & ws.Cells(2, i).Value & "</th>"
Next i
For i = 35 To 51 ' AI2:AY2 corresponds to columns 35 to 51
EmailBody = EmailBody & "<th>" & ws.Cells(2, i).Value & "</th>"
Next i
EmailBody = EmailBody & "</tr>"
' Add data to the table
EmailBody = EmailBody & "<tr><td>" & ws.Range("B2").Value & "</td>"
For i = 9 To 15
EmailBody = EmailBody & "<td>" & ws.Cells(FilteredRow.Row, i).Value & "</td>"
Next i
For i = 35 To 51
EmailBody = EmailBody & "<td>" & ws.Cells(FilteredRow.Row, i).Value & "</td>"
Next i
EmailBody = EmailBody & "</tr>"
' Close the table and HTML tags
EmailBody = EmailBody & "</table></body></html>"
' Create a new Outlook application object
Set OutlookApp = CreateObject("Outlook.Application")
' Find the open email
If OutlookApp.Inspectors.Count > 0 Then
For Each olInspector In OutlookApp.Inspectors
If olInspector.CurrentItem.Class = olMail Then
Set OutlookMail = olInspector.CurrentItem
' Update the email body
OutlookMail.HTMLBody = OutlookMail.HTMLBody & "<br><br>" & EmailBody
OutlookMail.Display ' Stellen Sie sicher, dass die E-Mail geöffnet bleibt
End If
Next olInspector
Else
MsgBox "Es wurde keine geöffnete Mail gefunden.", vbInformation
End If
Else
MsgBox "Es sind keine oder mehrere Zeilen gefiltert.", vbExclamation
End If
Else
MsgBox "Keine gefilterte Zeile.", vbExclamation
End If
' Clean up
Set FilteredRow = Nothing
Set ws = Nothing
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
|