code hebt sich auf...denk ich mir :-(
24.12.2019 17:06:56
Niko
Frohe Weihnachten an alle...wünsche Friede, Freude und Gesundheit :-)
habe ein "kleines" Problemchen das mich nicht am Heilig Abend in ruh das Fest Genießen lässt :-)
Wenn ich die beiden Codes in ein Blatt reinschreibe bekomme ich Probleme.
Anbei der gesamte Code im Blatt und das Blatt selbst als Datei.
https://www.herber.de/bbs/user/133954.xlsm
-------------------------------------------------------------------------------------------------------------------
Option Explicit
Sub Excel_Sheet_via_Outlook_Jan()
ActiveWorkbook.ActiveSheet.Unprotect ("1234")
Dim i As Long, strAn As String, GruppenName, KasseMonat As String
Dim MyMessage As Object, MyOutApp As Object, SavePath As String, AWS As String
GruppenName = ThisWorkbook.Sheets("DPV1").Range("A3")
KasseMonat = Month(CDate(ThisWorkbook.Sheets("DPV1").Range("E4"))) & "/" _
& Year(CDate(ThisWorkbook.Sheets("DPV1").Range("E4")))
SavePath = Environ("TEMP")
Worksheets("DPV1").Copy
With ActiveSheet
With .UsedRange
.Copy
.PasteSpecial xlPasteValues
End With
Union(.Range("FA:HA"), .Range("HB:HZ"), .Range("IA:XFD")).Delete
.Range("61:1048576").Delete
End With
ActiveSheet.UsedRange.Copy
ActiveSheet.Cells().PasteSpecial xlPasteValues
Application.DisplayAlerts = False
Application.Workbooks(Application.Workbooks.Count).SaveAs ThisWorkbook.Path & "\" _
& "Dienstplangestaltung " & "_" & GruppenName & "_" & Format(Now, "ddmmyyyy__hhmm") & ".xlsx"
With Application.Workbooks(Workbooks.Count)
AWS = .FullName
.Close
End With
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With Worksheets("DPV1")
For i = 48 To .Cells(.Rows.Count, "E").End(xlUp).Row
If strAn = vbNullString Then
strAn = .Cells(i, "E")
Else
strAn = strAn & ";" & .Cells(i, "E")
End If
Next i
End With
With MyMessage
.To = strAn
.cc = Worksheets("DPV1").Range("E47")
.Subject = "Dienstplangestaltung - Gruppe: " & GruppenName & " - Monat: " _
& KasseMonat & " - " & Date & "-" & Time
.Attachments.Add AWS
'Hier wird eine normale Text Mail erstellt
'.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
'Hier wird die HTML Mail erstellt
.Body = "Hallo Liebe Kollegen*innen," & vbCrLf & vbCrLf & "Im Anhang dieser E-Mail befindet sich die " _
& "Dienstplanung unserer Gruppe " & GruppenName & (KasseMonat) & " in Form einer Excel Datei." & vbCrLf _
& "Die Datei wird automatisch generiert, bitte beim Aufmachen der Datei alle" _
& " Vormeldungen zu akzeptieren/aktivieren oder/und auf Weiter zu Drücken." & vbCrLf _
& vbCrLf & "Zu öffnen mit dem MS Excel Programm oder einem Excel kompatiblen Programm." _
& vbCrLf & vbCrLf & vbCrLf & "Vielen Dank," & vbCrLf & GruppenName & ""
'Hier wird die Mail nochmals angezeigt
.GetInspector ' sorgt für die Signatur
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
'Hier wird die temporäre Datei wieder gelöscht
Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
ActiveWorkbook.ActiveSheet.Protect ("1234")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
ActiveWorkbook.ActiveSheet.Unprotect ("1234")
With Range("A10:EZ40").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.PatternTintAndShade = 1
End With
If Not Intersect(Target, Range("A10:EZ40")) Is Nothing Then
With Range(Cells(Target.Row, 1), Cells(Target.Row, 156)).Interior
.Pattern = xlGray25
.PatternThemeColor = xlThemeColorAccent5
.PatternTintAndShade = 0.399945066682943
End With
Target.Activate
End If
ActiveWorkbook.ActiveSheet.Protect ("1234")
End Sub
-------------------------------------------------------------------------------------------------------------
Danke im Voraus und nochmal Frohes Fest :-)