Hallo zusammen,
ich habe Dank eurer Hilfe im Forum ein Makro, welches mir einen Filter durchläuft und den Inhalt per Mail versendet, das funktioniert super.
Neu ist, dass ich einen weiteren Filter in einer anderen Spalte setzen will und weiterhin die Daten versenden möchte sofern welche vorliegen und genau daran scheitere ich.
Heißt, ich möchte für jeden gefilterten Eintrag in Spalte 1 prüfen ob in Spalte 13 auch ein Wert steht (>"") und wenn ja, dieser Teil kopiert und versendet wird.
Wer kann mir dabei bitte weiterhelfen?
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
Set objOutlook = CreateObject("Outlook.Application")
' prüfen ob Filter bereits gesetzt sind
If DB_Blatt.AutoFilterMode = False Then DB_Blatt.Cells.AutoFilter Field:=1
If DB_Blatt.AutoFilterMode Then DB_Blatt.AutoFilter.ShowAllData
'Filter setzen
Set objDic = CreateObject("Scripting.Dictionary")
varDaten = DB_Blatt.AutoFilter.Range.Columns(1)
DB_Blatt.Range(DB_Blatt.AutoFilter.Range.Address).AutoFilter Field:=13, Criteria1:=">" ' neu
'Anzahl der Werte aus Filter
For ZählerFilter = LBound(varDaten) + 1 To UBound(varDaten)
objDic(varDaten(ZählerFilter, 1)) = 0
Next ZählerFilter
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 Eintrag
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 Pfad1 & "\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 = "Test " & Date & " " & Time '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