Auswahlkriterien MailGefiltertProAnwender

Option Explicit
'Definition von Makroweit gültigen Variablen
Const QuelleSheet As String = "Liste"
Const QuelleZeileAb As Long = 1
Const QuelleSpalteAb As Long = 1
Const QuelleSpalteBis As Long = 21
Const QuelleSpalteKST As Long = 2
'Const PfadSpeichern As String = "C:\TestTMP"
Const PfadSpeichern As String = "H:\Projekte\Ausbildungswesen_2013\Excel_Programmierung\ _
Erinnerungstabellen_Test"
Const NameSpeichern As String = "Erinnerungsmail" '+ Anwender 1 usw.
'Definition der Mail-Inhalte
Const MailSheet As String = "Kst-Koordinator"
Const MailColKST As Long = 1
Const MailColName As Long = 2
Const MailColAddy As Long = 3
Const MailSubject As String = "Zusammenfassung von der Arbeitssicherheit für verantwortliche  _
Kostenstellen " '+Anwender 1 usw
Const MailText1 As String = "Hallo " '+Anwender
Const MailText2 As String = ", 

hier ist Ihre Zusammenfassung!"  'HTML-Tags im Text nutzen!  _
_
_
Sub MailGefilterttProAnwender()
'Verschickt ein Mail an jeden Kostenstellenverantwortlichen, wenn in SPalte K das Datum = Jahr   _
_
2014 hat - und erstellt ein Backup
'On Error GoTo hell   'WICHTIG! Im Sub werden Displayalerts abgeschaltet, die müssen on Error _
Const SpalteFiltern As Long = 10   'Jahre stehen in Spalte J = 10
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim rAnwender As Range
Dim lRow As Long
Dim NameOfSave As String
Dim TextPerson As String
'das Workbook merken - denn später geht es in andere Workbooks!
Set wkbOld = ActiveWorkbook
'Autofilter setzen
Call DoResetAutofilter(Sheets(QuelleSheet), QuelleSpalteAb, QuelleSpalteBis, QuelleZeileAb)
'Nach 2014 filtern - einfach aus dem Makrorekorder holen!
Sheets(QuelleSheet).Range("A1").AutoFilter Field:=SpalteFiltern, Operator:=xlFilterValues,  _
Criteria2:=Array(0, "8/1/2013")
With Sheets(MailSheet)
'Alle KST einmal durchlaufen
lRow = .Cells(.Rows.Count, MailColKST).End(xlUp).Row
For Each rAnwender In .Cells(2, 1).Resize(lRow - 1, 1)
'Nach KST filtern
Sheets(QuelleSheet).Range("A1").AutoFilter Field:=QuelleSpalteKST, Criteria1:= _
rAnwender.Value
lRow = .Cells(.Rows.Count, QuelleSpalteKST).End(xlUp).Row
If Not lRow = 1 Then    'denn dann wurden keine Einträge für diese Kst gefunden,  _
ergo kein Mail nötig!
'gefilterten Bereich und Überschriften kopieren
Sheets(QuelleSheet).UsedRange.SpecialCells(xlCellTypeVisible).Copy
'neues Workbook öffnen und merken - neues Workbook ist automatisch im Focus!
Workbooks.Add
Set wkbNew = ActiveWorkbook
'gefilterte Tabelle einfügen und Spaltenbreiten anpassen
With ActiveSheet
.Range("A1").PasteSpecial
.Cells.EntireColumn.AutoFit
End With
'neues Workbook speichern (Displayalerts gegen "Datei existiert schon" Dialog)
NameOfSave = PfadSpeichern & "\" & NameSpeichern & rAnwender.Offset(0, 1).Value  _
_
& ".xlsx"
Application.DisplayAlerts = False
wkbNew.SaveAs Filename:=NameOfSave, FileFormat:=xlOpenXMLWorkbook, CreateBackup: _
_
=False
wkbNew.Close False
Application.DisplayAlerts = True
wkbOld.Activate 'Zur sicherheit
'Individualisierte Mail mit Anhang senden
TextPerson = MailText1 & rAnwender.Offset(0, 1).Value & MailText2
Call SendWithOutlook(MailSubject & rAnwender.Offset(0, 1).Value, rAnwender. _
Offset(0, 2).Value, "", TextPerson, NameOfSave)
End If
Next rAnwender
End With
GoTo heaven:
hell:
Application.EnableEvents = True
MsgBox "Fehler in Sub FiltereProAnwender" & vbCrLf _
& "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
heaven:
End Sub
Private Sub SendWithOutlook(sSubject As String, sTo As String, sCC As String, sText As String,   _
_
_
AWS As String)
'Sub to send Excel-Sheet directly with outlook
Dim olApp         As Object
Dim olOldBody     As String
'Make Email
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.GetInspector.Display
olOldBody = .htmlBody
.To = sTo
.cc = sCC
.Subject = sSubject
.htmlBody = sText & olOldBody
.Attachments.Add AWS
End With
End Sub