VBA/Makro Hilfe! Filtereingabe für alle Blätter übernehmen

Question

Guten Tag,

folgendes Problem:

ich habe in den letzten Wochen mehrere Excel Dateien geschrieben, welche beliebig viele Blätter enthalten.
Jede Datei hat jedoch in der Spalte A-F die selben Daten. Also es sind immer die selben Produkte mit der selben Beschreibung. Die Reihenfolge ändert sich nur, wenn der Filter verändert wird.

Wenn ich jetzt bei einem Produkt etwas ändern möchte, muss ich auf jedem Blatt die Produktnummer im Filter eingeben, damit mir nur das Produkt angezeigt wird. Bei mehr als 50 Blättern ist das logischerweise ein ziemlicher "Aufwand".

Meine Frage lautet: Ist es möglich durch Makros (kenne mich leider damit noch nicht aus), die Filtereingabe auf einem beliebigen Blatt auszuführen, sodass ich auf jedem Blatt nur das eine Produkt angezeigt bekomme?
Super wäre es wenn es nicht Filter (Spalte) abhängig wäre (z.B. nur für den Filter Produktnummer aber nicht für Produkttyp), jedoch wäre auch das schon eine Erleichterung!!

Beispiel am Bild:

Ich möchte gerne alles über das Produkt 123456789 wissen. Gebe diese Nummer im Filter "Product Number" ein und wenn ich auf Blatt "Origin" wechsel, wird mir ebenfalls nur dieses Produkt angezeigt.
 

Oder um Produkte zu vergleichen: Gebe ich den Filter bei "Type of Product" auf Food und sehe auf alle Blättern alles Produkte unter Food.

Ich hoffe ich konnte mein Problem gut darstellen und mir kann geholfen werden.

Answer 1

Hallo Patrick,

kopiere das folgende Makro in ein Standard-Modul deiner Arbeitsmappe:

Sub filter_uebertragen()

Dim intSpalte As Integer
Dim intLSpalte As Integer
Dim arrFilter As Variant
Dim strTabelle As String
Dim i As Integer
Dim f As Integer
Dim bFilter As Boolean

'letzte Spalte in aktiver Tabelle ermitteln
intLSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column

'Array für Filtereinträge redimensionieren
ReDim arrFilter(intLSpalte)

'Filter durchlaufen
For intSpalte = 1 To intLSpalte
  With ActiveSheet.AutoFilter.Filters(intSpalte)
       If .On Then
          arrFilter(intSpalte) = .Criteria1    'Kriterium in Array schreiben
          bFilter = True                       'Marker, dass Filter gefunden wurde
       End If
  End With
Next intSpalte

'Falls kein Filter gefunden, dann Hinweis und Abbruch des Makros
If bFilter = False Then
  MsgBox "Kein Filter gefunden! Abbruch", 64, "Hinweis"
  Exit Sub
End If

'Name des aktiven Arbeitsblatts in Variable schreiben
strTabelle = ActiveSheet.Name

'alle Arbeitsblätter in Arbeitsmappe durchlaufen
For i = 1 To ThisWorkbook.Worksheets.Count
  'nur die anderen Arbeitsblätter durchlaufen
  If Worksheets(i).Name <> strTabelle Then
   For f = 1 To UBound(arrFilter)
     If arrFilter(f) <> "" Then Worksheets(i).UsedRange.AutoFilter Field:=f, Criteria1:=arrFilter(f)
   Next f
  End If
Next i

'Abschlussmeldung
 MsgBox "Die Filtereinstellungen wurden übertragen.", 64, "Hinweis"

End Sub

Wenn du deine Filter (einen oder auch mehrere) in einem Arbeitsblatt gesetzt hast, führe das Makro aus. Die Filter werden dann in alle anderen Arbeitsblätter der Mappe übertragen. Voraussetzung ist, dass alle Arbeitsblätter gleich aufgebaut sind (was ja bei dir der Fall ist).

Gruß

M.O.

Answer 2

Hallo Patrick,

hab eine Datei mit Makros vorbereitet, gesucht wird in der Spalte B in allen Blättern.

http://www.imagenetz.de/fcb23577f/SUCHE.xlsm.html

Gruß

jofed

Answer 3

Vielen Dank m-o,

leider bekomme ich folgende Fehlermeldung: Laufzeitfehler '13': Typen unverträglich.

Wenn ich auf debuggen klicke, markiert er die Zeile  If arrFilter(f) <> "" Then gelb

Wenn ich dann nochmal auf Extras -> Makros -> Ausführen gehe sagt er mir, dass der Code nicht im Haltemodus ausgeführt werden kann.

Answer 4

Hallo,

kannst du mal eine Beispieltabelle hochladen. Wie du das hier im Forum machen kannst, du hier nachlesen: Anleitung

Gruß

M.O.

Answer 5

Wenn ich das in einer Test Datei, wo ich nur ein kleinen Teil habe funktioniert das Makro tatsächlich. Könnte es daran liegen, dass ich in der richtigen Datei Verknüpfungen haben? Also die Spalten A-F beruhen auf den Daten einer anderen Datei.

Leider kann ich die Datei aus datenschutztechnischen Gründen nicht hochladen.

Ich versuche mal was zusammenzubasteln mit dem selben Fehler

Answer 6

Ich kann noch sagen, in einer anderen Datei (In jeder Datei ist Spalte A-F identisch (außer der Filter wurde anders gesetzt)) bekomme ich die Fehlermeldung: Laufzeitfehler '91': Objektvariable oder With-Blockvariable nicht festgelegt.

Wenn ich auf Debuggen gehe markiert er Zeile 15 ,,With ActiveSheet.AutoFilter.Filters(intSpalte)" gelb

Answer 7

Hallo,

für die Filter ist es eigentlich egal, ob die Daten als Werte oder Verknüpfungen in der Datei stehen.

Ich habe das Makro noch einmal etwas überarbeitet, so dass nur die Filter aus den Spalten A bis F ausgelesen werden (vorher aus allen belegten Spalten). Probiere mal, ob das Makro jetzt besser läuft:

Sub filter_uebertragen_neu()

Dim intSpalte As Integer
Dim arrFilter(6) As Variant
Dim strTabelle As String
Dim i As Integer
Dim f As Integer
Dim bFilter As Boolean

'Filter durchlaufen
For intSpalte = 1 To 6
  With ActiveSheet.AutoFilter.Filters(intSpalte)
       If .On Then
          arrFilter(intSpalte) = .Criteria1    'Kriterium in Array schreiben
          bFilter = True                       'Marker, dass Filter gefunden wurde
       End If
  End With
Next intSpalte

'Falls kein Filter gefunden, dann Hinweis und Abbruch des Makros
If bFilter = False Then
  MsgBox "Kein Filter gefunden! Abbruch", 64, "Hinweis"
  Exit Sub
End If

'Name des aktiven Arbeitsblatts in Variable schreiben
strTabelle = ActiveSheet.Name

'alle Arbeitsblätter in Arbeitsmappe durchlaufen
For i = 1 To ThisWorkbook.Worksheets.Count
  'nur die anderen Arbeitsblätter durchlaufen
  With Worksheets(i)
   If .Name <> strTabelle Then
     'ggf. gesetzte Filter zurücksetzen
     If .FilterMode Then .ShowAllData
     'nun Filter neu setzen
     For f = 1 To UBound(arrFilter)
       'nur nichtleere Filter ansprechen
       If arrFilter(f) <> "" Then Worksheets(i).UsedRange.AutoFilter Field:=f, Criteria1:=arrFilter(f)
     Next f
    End If
  End With
Next i

'Abschlussmeldung
 MsgBox "Die Filtereinstellungen wurden übertragen.", 64, "Hinweis"

End Sub

Gruß

M.O.

Answer 8

Vielen Dank für die Bemühungen!

Ich habe das Makro ausprobiert, jedoch bekomme ich eine Fehlermeldung + eine Zeile wird markiert. (Siehe Bilder)

Answer 9

Hier ist die Datei ohne Daten

Answer 10

Hallo,

ich bin davon ausgegangen, dass die Tabellen immer gleich aufgebaut sind, d.h. dass auch die Spalten immer in der gleichen Reihenfolge in den einzelnen Blättern stehen. Dies ist jedoch nicht der Fall. Auch sind die Daten in Tabellen organisiert.

Probiere mal das folgende Makro aus:

Sub filter_uebertragen_neu()

Dim intSpalte As Integer
Dim arrFilter(6, 1) As Variant
Dim strTabelle As String
Dim i As Integer
Dim f As Integer
Dim bFilter As Boolean
Dim intFilterzeile As Integer

'Filter durchlaufen
For intSpalte = 1 To 6
  With ActiveSheet.AutoFilter.Filters(intSpalte)
       If .On Then
          arrFilter(intSpalte, 0) = Cells(ActiveSheet.AutoFilter.Range(1).Row, intSpalte).Value  'Überschrift des Filters in Array schreiben
          arrFilter(intSpalte, 1) = .Criteria1   'Kriterium in Array schreiben
          bFilter = True                       'Marker, dass Filter gefunden wurde
       End If
  End With
Next intSpalte

'Falls kein Filter gefunden, dann Hinweis und Abbruch des Makros
If bFilter = False Then
  MsgBox "Kein Filter gefunden! Abbruch", 64, "Hinweis"
  Exit Sub
End If

'Name des aktiven Arbeitsblatts in Variable schreiben
strTabelle = ActiveSheet.Name

'alle Arbeitsblätter in Arbeitsmappe durchlaufen
For i = 1 To ThisWorkbook.Worksheets.Count
  'nur die anderen Arbeitsblätter durchlaufen
  With Worksheets(i)
   If .Name <> strTabelle Then
     'ggf. gesetzte Filter zurücksetzen
     If .FilterMode Then .ShowAllData
     'nun Filter neu setzen
     For f = 1 To 6
       'nur nichtleere Filter ansprechen
       If arrFilter(f, 1) <> "" Then
        'richtiges Feld für Filter suchen
        For intSpalte = 1 To 6
          If .Cells(.ListObjects(1).HeaderRowRange.Row, intSpalte).Value = arrFilter(f, 0) Then
            'Filter übertragen
            .ListObjects(1).Range.AutoFilter Field:=intSpalte, Criteria1:=arrFilter(f, 1)
          End If
        Next intSpalte
       End If
      Next f
    End If
  End With
Next i

'Abschlussmeldung
 MsgBox "Die Filtereinstellungen wurden übertragen.", 64, "Hinweis"

End Sub

Gruß

M.O.