Wiederholtes Datenfiltern vereinfachen
Das
ich bräuchte noch einmal eure Hilfe. Aus einer Datenbank filtere ich Daten und speicher sie in bestimmte Bereiche. Da der Vorgang sich wiederholt und sich nur die Kriterien und er Zielbereich ändert, müsste man den Code doch bestimmt vereinfachen können.
Es muss sich jetzt niemand die Mühe machen und mir den kompletten Code umschreiben, es genügt mir, wenn ich einen Vorschlage mit den ersten 2 bis 3 Datenfiltern bekomme.
Sub DBfiltern()
With ActiveSheet.Range("o1:w1000")
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l4:m5"), CopyToRange:=Range("z1"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l6:m7"), CopyToRange:=Range("z11"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l9:m10"), CopyToRange:=Range("z21"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l11:m12"), CopyToRange:=Range("z31"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l14:m15"), CopyToRange:=Range("z41"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l16:m17"), CopyToRange:=Range("z51"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l19:m20"), CopyToRange:=Range("z61"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l21:m22"), CopyToRange:=Range("z71"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l24:m25"), CopyToRange:=Range("z81"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l26:m27"), CopyToRange:=Range("z91"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l29:m30"), CopyToRange:=Range("z101"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l31:m32"), CopyToRange:=Range("z111"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l34:m35"), CopyToRange:=Range("z121"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l36:m37"), CopyToRange:=Range("z131"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l39:m40"), CopyToRange:=Range("z141"), Unique:=False
.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("l41:m42"), CopyToRange:=Range("z151"), Unique:=False
End With
Vielen Dank!
Gruß Holger