Zellen Bereich kopieren und in BodyText einfügen
Achim_71
Hallo,
ich habe mir folgenden Code , zusammen gebastelt, der auch so weit funktioniert.
Nun meine frage, in dem Code wird ja aus einer Tabelle ein bestimmter bereich Kobiert und in eine neue Tabelle eingefügt, den Code teil habe ich mal Fett geschrieben.
Besteht die Möglichkeit das Kopierte auch in den Body Text von der erzeugten E-Mail einzufügen?
Ich hoffe ich konnte es so einigermaßen erklären.
In voraus vielen Dank.
Achim
Sub Artikelliste()
Application.ScreenUpdating = False
Sheets("Artikelliste").Select
Dim aktivezelle As String
Dim zahl As Long 'die zusuchende zahl
Dim zeile As Integer
Dim vorhanden As Boolean: vorhanden = False
ActiveSheet.Unprotect "Test"
Sheets(Sheets("datei").Range("o3").Value).Visible = True
'## Inhalte löschen
Sheets(Sheets("Datei").Range("o3").Value).Select
Range("A17:I100").Select
Application.CutCopyMode = False
Selection.ClearContents
Selection.ClearComments
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A17").Select
Sheets("Datei1").Select
Range("C7").Select
'##Autofilter aufheben
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
'## Filter
aktivezelle = ActiveCell.Address
zahl = 1 'InputBox("Welche Zahl soll gesucht werden?")
zeile = Range("a1048576").End(xlUp).Row
Range("a1048576").End(xlUp).Select
Do While ActiveCell.Row > 1
If ActiveCell.Value = zahl Then
vorhanden = True
Range(Cells(ActiveCell.Row, ActiveCell.Offset(0, 1).Column), Cells(ActiveCell.Row, ActiveCell.Offset(0, 16).Column)).Copy
Sheets(Sheets("Datei").Range("o3").Value).Select
Range("A1048576").End(xlUp).Select
'MsgBox "1."
Range(Cells(ActiveCell.Offset(1, 0).Row, ActiveCell.Column), Cells(ActiveCell.Offset(1, 0).Row, ActiveCell.Offset(0, 16).Column)).Select
'MsgBox "2." Änderung kopie
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Datei1").Select
End If
Cells(zeile, 1).Select
zeile = zeile - 1
Loop
Range(aktivezelle).Select
Application.ScreenUpdating = True
'## Daten kopieren
Sheets("Datei1").Select
Range("C7:C11").Select
Selection.Copy
Sheets(Sheets("datei").Range("o3").Value).Select
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Datei1").Select
Range("f4").Select
Selection.Copy
Sheets(Sheets("Datei").Range("o3").Value).Select
Range("e4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Datei1").Select
Range("f9").Select
Selection.Copy
Sheets(Sheets("Datei").Range("o3").Value).Select
Range("e9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Datei1").Select
Range("e12").Select
Selection.Copy
Sheets(Sheets("Datei").Range("o3").Value).Select
Range("d12").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'** Das aktive Tabellenblatt wird über Outlook versendet
'** Dimensionierung der Variablen
Application.ScreenUpdating = False
Dim strBlatt As String
Dim strDatei As String
Dim strPfad As String
Dim outObj As Object
Dim Mail As Object
Dim strBodyText As String
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
'** Pfad für temporäre Zwischenspeicherung angeben
strPfad = "C:\Temp" 'entsprechend anpassen
'** Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
strBlatt = ActiveSheet.Name
'** Gewähltes Tabellenblatt kopieren
Sheets(strBlatt).Copy
'** Blatt temporär in vorgegebenes Verzeichnis abspeichern
ActiveWorkbook.SaveAs strPfad & "\" & ActiveSheet.Name
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = ActiveWorkbook.FullName
strBodyText = "Sehr geehrte Damen und Herren,"
'** Mail erzeugen
With Mail
.To = Range("L1")
.CC = ""
.Subject =
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.Body = strBodyText
End With
'** Erzeugte Datei schließen
Workbooks(Dir(strDatei)).Close
'** Erzeugte Datei wieder löschen
Kill (strDatei)
'** E-Mail anzeigen
Mail.Display