Code für Autofilter mit Ausnahmen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Makro1() Dim oDic As Object, meArray Dim A As Long, MaxRow As Long Set oDic = CreateObject("Scripting.Dictionary") 'Tabelle anpassen With Sheets("Tabelle1") 'Filter aufheben If .FilterMode Then .ShowAllData 'Bereich der Namen ohne Überschrift MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow = 1 Then 'keine Namen Exit Sub ElseIf MaxRow > 2 Then 'mehr als 1 Name meArray = .Range("A2", .Cells(MaxRow, 1)) Else 'nur ein Name in Liste meArray = .Range("A2", .Cells(MaxRow, 2)) Redim Preserve meArray(1 To Ubound(meArray), 1 To 1) End If 'doppelte rausfiltern For A = 1 To Ubound(meArray) oDic(meArray(A, 1)) = meArray(A, 1) Next meArray = oDic.Keys 'Schleife über alle namen For A = Lbound(meArray) To Ubound(meArray) .Columns(1).AutoFilter Field:=1, Criteria1:=meArray(A) 'Code für Ausdruck '... '... Next A End With End Sub

Hallo Klaus M.vdT,
vielen Dank, aber Dein Lösungsansatz funktioniert bei mir nicht, weil es sich immer wieder um eine neue Datei handelt, welche ich aus unserem Intranet erst erzeuge (nach Excel exportiere).
Mein Ansatz ist ja auch, dass ich ausgeschiedenen oder neue Mitarbeiter nicht händisch ergänzen muss.
Hallo Tino,
auch Dir vielen Dank, dass Du mir helfen möchtest.
Dein Ansatz scheint auch der richtige zu sein, funktioniert aber noch nicht so ganz.
Ich möchte an dieser Stelle nochmal erwähnen, dass meine VBA- Kenntnisse als "bescheiden" einzustufen sind.
Deinen Code habe ich zweimal ausprobiert und habe jeweils 8-10 Blätter ohne Daten (also gefilterten Mitarbeiter) ausgedruckt bekommen. Komischerweise in verschiedenen Reihenfolgen.
Die benötigten Blätter der vorhandenen Mitarbeiter waren allerdings auch dabei. Insofern ist die Lösung scheinbar nicht fern.
Muss ich außer dem Druckbefehl noch etwas in dem Code ergänzen.
Wie erkennt der Code die Filter, die ich nicht ausgedruckt haben möchte?
Ich habe mal eine Beispielsdatei mal hochgeladen.
https://www.herber.de/bbs/user/71728.xls
Hinweise:
1) die zu filternden Mitarbeiter sind in Spalte A ab Zeile 10
2) die ausgeblendeten Spalten werden nicht benötigt
3) Folgende Filter aus Spalte A sollen nicht ausgedruckt werden:
Filter in denen die Wörter "Postkorb" oder "Summe" vorkommen
Wer hilft mir bei der perfekten und papiersparenden Lösung?
Nochmals vielen Dank im voraus.
Gruß, Harald.

Sub Makro1() Dim oDic As Object, meArray Dim A As Long, MaxRow As Long Set oDic = CreateObject("Scripting.Dictionary") 'Tabelle anpassen With Sheets("Wochenmeldung") 'Filter aufheben If .FilterMode Then .ShowAllData 'Bereich der Namen ohne Überschrift MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow = 7 Then 'keine Namen Exit Sub ElseIf MaxRow > 10 Then 'mehr als 1 Name meArray = .Range("A10", .Cells(MaxRow, 1)) Else 'nur ein Name in Liste meArray = .Range("A10", .Cells(MaxRow, 2)) Redim Preserve meArray(1 To Ubound(meArray), 1 To 1) End If 'doppelte rausfiltern For A = 1 To Ubound(meArray) If meArray(A, 1) <> "" Then 'keine leeren Zellen If InStr(meArray(A, 1), "Liste erstellt am") = 0 Then 'keine Fußzeile oDic(meArray(A, 1)) = meArray(A, 1) End If End If Next meArray = oDic.Keys 'Schleife über alle namen For A = Lbound(meArray) To Ubound(meArray) .Range("A7", .Cells(MaxRow, 1)).AutoFilter Field:=1, Criteria1:=meArray(A) 'Code für Ausdruck .PrintOut Copies:=1, Collate:=True Next A End With End Sub

Hallo,
habe ein Array erstellt in dem Du Deine Ausnahmen eintragen und auch leicht erweitern kannst.

Sub Makro1()
Dim oDic As Object, meArray
Dim A As Long, MaxRow As Long
Dim ArrayAusnahme, booNot As Boolean, AA As Long

'Ausnahmen entsprechend erweitern 
ArrayAusnahme = Array("Summe", "Liste erstellt am", "Postkorb")

Set oDic = CreateObject("Scripting.Dictionary")

'Tabelle anpassen 
With Sheets("Wochenmeldung")
  'Filter aufheben 
  If .FilterMode Then .ShowAllData
  
  'Bereich der Namen ohne Überschrift 
  MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
  If MaxRow = 7 Then 'keine Namen 
    Exit Sub
  ElseIf MaxRow > 10 Then 'mehr als 1 Name 
    meArray = .Range("A10", .Cells(MaxRow, 1))
  Else 'nur ein Name in Liste 
    meArray = .Range("A10", .Cells(MaxRow, 2))
    Redim Preserve meArray(1 To Ubound(meArray), 1 To 1)
  End If

    'doppelte rausfiltern 
    For A = 1 To Ubound(meArray)
      If meArray(A, 1) <> "" Then 'keine leeren Zellen 
            oDic(meArray(A, 1)) = meArray(A, 1)
      End If
    Next
    
    meArray = oDic.Keys
    
    'Schleife über alle namen 
    For A = Lbound(meArray) To Ubound(meArray)
        For AA = Lbound(ArrayAusnahme) To Ubound(ArrayAusnahme)
            booNot = InStr(meArray(A), ArrayAusnahme(AA)) > 0
            If booNot Then Exit For
        Next AA
        If Not booNot Then
            .Range("A7", .Cells(MaxRow, 1)).AutoFilter Field:=1, Criteria1:=meArray(A)
            'Code für Ausdruck 
            .PrintOut Copies:=1, Collate:=True
            'kleine Pause nach Ausdruck, eventuell anpassen oder löschen 
            Application.Wait Now + TimeSerial(0, 0, 5)
            DoEvents
        End If
        booNot = False
    Next A
    If .FilterMode Then .ShowAllData
End With
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Code für Autofilter mit Ausnahmen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread