Bestimmten Bereich auswählen
23.09.2020 17:12:32
Marcel
ich habe ein für mich großes und für euch wahrscheinlich kleines Problem. Es geht sich um den nachfolgenden VBA-Code, der soweit gut funktioniert, allerdings wollte ich dort eine kleine Anpassung vornehmen, was mir nicht so recht gelingen will.
In dem unten aufgeführten Code geht es sich speziell um diesen Bereich:
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Worksheets("Tabelle2").Range("A8:F12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Hier wird auf dem Tabellenblatt 2 der Bereich A8:G12 ausgewählt, der schlussendlich automatisch in eine E-Mail (Outlook) eingefügt werden soll. Der Bereich ist so aufgebaut, dass von A8:F8 die Überschriften stehen und der übrige Bereich anderweitig gefüllt ist. Von E9:E12 stehen Istwerte und von F9:F12 sind Sollwerte eingetragen. Jetzt sollen nur Zeilen innerhalb des Bereiches (inkl. Überschrift) ausgewählt und in die E-Mail übertragen werden, wo der Istwert größer Sollwert ist.
Des Weiteren würde ich gerne in dem letzten Abschnitt (dort wo LINK steht) einen Hyperlink einfügen:
.HTMLBody = "Text" & RangetoHTML(rng) & "Text" & LINK & signature
Die Tabelle oben stellt nur einen kleinen Ausschnitt dar bzw. es gibt viele einzelner solcher Tabellen, weshalb es händisch sehr aufwendig und Fehleranfällig ist. Aus diesem Grund würde ich gerne eine VBA basierte Lösung haben.
Vielen Dank im Voraus für eure Unterstützung!
Kompletter VBA-Code:
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range, i As Long, j As Long
Dim OutApp As Object
Dim OutMail As Object
Dim signature As String
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Worksheets("Tabelle2").Range("A8:G12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
signature = .HTMLBody
.To = Worksheets("Tabelle2").Range("B3")
.CC = ""
.BCC = ""
.Subject = Worksheets("Tabelle2").Range("B4")
.HTMLBody = "Text" & RangetoHTML(rng) & "Text" & LINK & signature
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub