Hallo zusammen,
ich habe ein Makro welches mir dabei helfen soll, den Inhalt aus einer Tabelle an einen entsprechenden Empfänger zu senden, was in meinem bisherigen Anwendungsfall funktioniert.
Neu ist, dass ich zwei Filter benötige und die Filterung erst ab Zeile 3 starten kann, da die darüberliegenden Zeilen Überschriften tragen die ich benötige.
Wie kann ich erreichen, dass die zwei Filter ab Zeile 3 Anwendung finden und das Makro die Namen im ersten Filter durchläuft, damit jeder Empfänger seinen entsprechenden Datensatz erhält?
Sub Filtern_und_versenden()
Dim objDic As Object
Dim arrDaten
Dim varDaten
Dim ZählerFilter As Long
Dim AktuellesTB As String
Dim NeueDatei As String
Dim objOutlook As Object
Dim objMail As Object
Dim Übersicht As Worksheet
Set Übersicht = ThisWorkbook.Sheets("Übersicht")
Set objOutlook = CreateObject("Outlook.Application")
' prüfen ob Filter bereits gesetzt sind
If Übersicht.AutoFilterMode = False Then Übersicht.Rows(3).AutoFilter Field:=1
If Übersicht.AutoFilterMode Then Übersicht.AutoFilter.ShowAllData
Übersicht.Range(Übersicht.AutoFilter.Range.Address).AutoFilter Field:=3, Criteria1:="Mitarbeiter" '
'Filter setzen
Set objDic = CreateObject("Scripting.Dictionary")
With Übersicht
For ZählerFilter = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(ZählerFilter, 3) = "Mitarbeiter" Then
objDic(.Cells(ZählerFilter, 1).Text) = 0
End If
Next
End With
arrDaten = objDic.keys
'Filter durchlaufen
For ZählerFilter = 0 To UBound(arrDaten)
DB_Blatt.Range(DB_Blatt.AutoFilter.Range.Address).AutoFilter Field:=1, Criteria1:=arrDaten(ZählerFilter) 'jeweiliger Mitarbeiter
If arrDaten(ZählerFilter) > "" Then
'gefilterte Daten kopieren
DB_Blatt.Range("A1:O" & DB_Blatt.UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy
'neue Arbeitsmappe öffnen und Daten einfügen
Workbooks.Add
AktuellesTB = ActiveWorkbook.Name
Workbooks(AktuellesTB).Worksheets("Tabelle1").Range("A1").PasteSpecial
'Datei speichern
Workbooks(AktuellesTB).Worksheets("Tabelle1").SaveAs Pfad2 & "\Mail\" & arrDaten(ZählerFilter) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
NeueDatei = ActiveWorkbook.FullName
'aktuelle Datei schließen
Workbooks(Dir(NeueDatei)).Close
'neue Mail erzeugen
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = arrDaten(ZählerFilter)
.Subject = "Betreff"
.Body = "Hallo "
.Attachments.Add NeueDatei 'Anhang
.send
End With
'aktuelle Datei schließen und löschen
Kill (NeueDatei)
End If
Next ZählerFilter
'Filter zurücksetzen
If DB_Blatt.AutoFilterMode Then DB_Blatt.AutoFilterMode = False
Set objDic = Nothing
End Sub