Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1164to1168
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Wiederholtes Datenfiltern vereinfachen

Wiederholtes Datenfiltern vereinfachen
Das
Guten Morgen,
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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Wiederholtes Datenfiltern vereinfachen
30.06.2010 10:27:25
Rudi
Hallo,
evtl. so:
Sub DBfiltern()
prcFilter Range("l4:m5"), Range("z1")
prcFilter Range("l6:m7"), Range("z11")
prcFilter Range("l9:m10"), Range("z21")
prcFilter Range("l11:m12"), Range("z31")
prcFilter Range("l14:m15"), Range("z41")
End Sub
Sub prcFilter(rngKriterium As Range, rngZiel As Range)
With ActiveSheet.Range("o1:w1000")
.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium, _
CopyToRange:=rngZiel, _
Unique:=False
End With
End Sub

Gruß
Rudi
AW: Wiederholtes Datenfiltern vereinfachen
30.06.2010 10:50:24
Das
Danke Rudi, das sieht sehr gut aus!
Noch eine grundsätzliche Frage: Kann man die Kriterien auch direkt im Code benennen? Man sieht im Filtercode ja nur ein "CriteriaRange".
Also wenn z.B. in l4:m5 und l6:m7 stehen würde
Tier | Farbe
Hase| braun
Tier | Farbe
Maus| grau
Gruß Holger
Anzeige
AW: Wiederholtes Datenfiltern vereinfachen
30.06.2010 11:11:26
Rudi
Hallo,
das geht nicht.
Man könnte aber die Kriterienbereiche in ein Array packen und dann mit einer Schleife arbeiten.
Sub DBfiltern()
Dim rngDB As Range, arrKriterium, iKriterium As Integer
arrKriterium = Array(Range("l4:m5"), Range("l6:m7"), Range("l9:m10"), _
Range("l11:m12"), Range("l14:m15"))
Set rngDB = ActiveSheet.Range("o1:w1000")
For iKriterium = 0 To UBound(arrKriterium)
With rngDB
.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=arrKriterium(iKriterium), _
CopyToRange:=Cells(iKriterium * 10 + 1, 26), _
Unique:=False
End With
Next iKriterium
End Sub

Gruß
Rudi
Anzeige
AW: Wiederholtes Datenfiltern vereinfachen
30.06.2010 11:21:37
Das
Hallo Rudi,
da ich sowieso mal mit Array arbeiten möchte, finde ich deine 2. Lösung besser.
Und ich habe etwas länger überlegen müssen, wie du die Zieladresse bestimmst, habe es jetzt aber kapiert. Auf so eine Idee würde ich erst gar nicht kommen ;-)
Vielen Dank!
Gruß Holger

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige