gelöst, hoffe ich!
13.06.2013 14:04:47
Klaus
Hi Tobias,
kopiere dir diesen Code in deine Datei und lass ihn einmal durchlaufen.
Anmerkung: die Erklärungs-Texte löscht du natürlich vorher :-)
Diese Zeile
Const PfadSpeichern As String = "C:\TestTMP\Mailfiles"
musst du als allererstes anpassen - oder einen Order C:\TestTMP\Mailfiles erstellen :-)
Rufe dann das Makro FiltereProAnwender auf.
Alles Variable habe ich hoffentlich nach oben ausgelagert, so dass Änderungen sehr einfach von dir vorgenommen werden können.
In dieser Zeile
Const MailText2 As String = ", XXXX hier ist deine Zusammenfassung!"
musst du XXXX durch den HTML-Tag für Zeilenumbruch ~f~
~f~ ersetzen! Das kann ich innerhalb der PRE-Tags leider nicht korrekt anzeigen lassen.
Option Explicit
'Definition von Makroweit gültigen Variablen
Const SheetUrsprung As String = "Sheet1"
Const PfadSpeichern As String = "C:\TestTMP\Mailfiles"
Const NameSpeichern As String = "MailFile_" '+ Anwender 1 usw.
Const ErsteSpalte As Long = 1 'Liste fängt in Spalte A an (A=1 usw), hier stehen _
die Anwender
Const ErsteZeile As Long = 2 'Einträge ab Zeile 2
Const MailAddSpalte As Long = 6 'Mailadressen in Spalte F = 6
Const NameDerTabelle As String = "Table1" 'deine definierte Tabelle heisst "Table1"
'Definition der Mail-Inhalte
Const MailSubject As String = "Zusammenfassung von / für " '+Anwender 1 usw
Const MailText1 As String = "Hallo " '+Anwender
Const MailText2 As String = ", XXXX hier ist deine Zusammenfassung!" 'HTML-Tags im Text nutzen! _
Sub FiltereProAnwender()
On Error GoTo hell 'WICHTIG! Im Sub werden Displayalerts abgeschaltet, die müssen on Error _
UNBEDINGT wieder an!
Dim rAnwender As Range
Dim LastRow As Long
Dim wkbNew As Workbook
Dim wkbOld As Workbook
Dim NameOfSave As String
Dim TextPerson As String
'das Workbook merken - denn später geht es in andere Workbooks!
Set wkbOld = ActiveWorkbook
With Sheets(SheetUrsprung)
'ACHTUNG! Autofilter darf bei Makrostart NICHT gesetzt sein! Reset per Makro
ResetAutoFilter
'letzte Zeile
LastRow = .Cells(.Rows.Count, ErsteSpalte).End(xlUp).Row
'Alle Anwender durchlaufen
For Each rAnwender In .Range(.Cells(ErsteZeile, ErsteSpalte), .Cells(LastRow, ErsteSpalte))
'Zähle, ob der Anwender das erste mal vorkommt
If WorksheetFunction.CountIf(.Range(.Cells(ErsteZeile, ErsteSpalte), .Cells(rAnwender. _
Row, ErsteSpalte)), rAnwender) = 1 Then
'filtere nach Anwender
.ListObjects(NameDerTabelle).Range.AutoFilter Field:=1, Criteria1:=rAnwender.Value
'nur gefilterten Teil der Tabelle kopieren
.ListObjects(NameDerTabelle).Range.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.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.Value & MailText2
Call SendWithOutlook(MailSubject & rAnwender.Value, .Cells(rAnwender.Row, _
MailAddSpalte).Value, "", TextPerson, NameOfSave)
Else
'mache nix, wenn der Anwender zum zweiten mal oder öfter vorkam
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:
'Autofilter wieder abschalten
ResetAutoFilter
End Sub
Sub ResetAutoFilter()
'Hier musst du eventuell den Namen des ListObject Table1 anpassen ...
With Sheets(SheetUrsprung).ListObjects(NameDerTabelle).Range
.AutoFilter Field:=1
.AutoFilter Field:=2
.AutoFilter Field:=3
.AutoFilter Field:=4
.AutoFilter Field:=5
.AutoFilter Field:=6
End With
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
'April 2013 by Klaus M.vdT.
'original Code by mumpel / www.herber.de / 11.04.2013 11:23:25
'https://www.herber.de/forum/messages/1308295.html
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