Mehrere Sheets filtern

[atilla]

Hallo,

dann wird es nichts ohne eine Beispieldatei!

Ich häng' meine Beispieldatei an, damit Du siehst, dass es unter gegebenen Umständen funktioniert.


  Spezialfilter über mehrere Tabellen.xlsm (Größe: 21,41 KB / Downloads: 2)

Fenneks Variante würde ich hier nicht nutzen.
Wenn dann würde die FindNext Methode in Frage kommen.

[atilla]

Hallo,

ok, hab die Beispielmappe gesehen, muss aber jetzt weg.
Meine Variante, so wie ich sie eingestellt habe, funktioniert nur, wenn die Daten als Liste ohne Leezeilen zu der Überschrift vorliegen.

Ich schau später noch einmal rein.

[excelgirl]

Danke das ist super nett !!

[Fennek]

Hallo,

Schleifen?

Ist gibt zwei Arten von Schleifen:

For i = 1 to 12 : mach was : next i

Oder

For each ws in thisworkbook.sheets : mach was : next

Da die for...next -Schleife nicht funktioniert, must du sie durch die genannte for ... each - Schleife ersetzen. Als Zusatz ist notwendig:

If ws.name <> "Result" thenn

der Code

End if

Mfg

[excelgirl]

Hallo,

Schleifen?

Ist gibt zwei Arten von Schleifen:

For i = 1 to 12 : mach was : next i

Oder

For each ws in thisworkbook.sheets : mach was : next

Da die for...next -Schleife nicht funktioniert, must du sie durch die genannte for ... each - Schleife ersetzen. Als Zusatz ist notwendig:

If ws.name <> "Result" thenn

der Code

End if

Mfg


Kannst du mir den Code möglicherweise aktualisieren ? ;)

[Fennek]

Hallo,

Nein, ich werde den Code nicht aktualisieren. Ich nutze ein Tablet für den Besuch hier im Forum, d.h. ich muss alle Code von Hand vom Pc übertragen.

Ich verstehe das Forum als Hilfe zur Selbsthilfe, etwas Eigenleistung zum Anpassen bzw debugging ist da meistens notwendig.

Ansonsten gibt es noch professionelle Excel-Entwickler, die gerne ein rund-um-sorglos-Paket erstellen.

Mfg

[atilla]

Hallo,

den von mir eingestellten Code "aktualisieren" mit folgendem austauschen.

Code:

Sub aktualisieren()
Dim i As Long
Dim lngA As Long, lngZ As Long
Dim lngL As Long
Dim strSuch As String
Sheets("Gesamtübersicht").Select   'falls mal versehentlich aus einer anderen Tabelle heraus aufgerufen wurde
strSuch = "prüfen" 'gesuchter Wert
Range("C1").CurrentRegion.Offset(1, 0).ClearContents
Range("AA1").CurrentRegion.Clear
lngZ = 2
Application.ScreenUpdating = False
For i = 1 To Sheets.Count
  If Sheets(i).Name <> ActiveSheet.Name Then
    With Sheets(i)
      lngA = Application.CountIf(Sheets(i).Columns("E"), strSuch)
      If lngA > 0 Then
        Range("AA1") = Range("D1")
       lngL = .Cells(.Rows.Count, 3).End(xlUp).Row
        Range("AA2") = strSuch
        .Range("C1:J" & lngL).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
          "AA1:AA2"), CopyToRange:=Range("AB1:AI1"), Unique:=False
        Range("AB2:AI" & lngA + 1).Copy Range("B" & lngZ)
        lngZ = lngZ + lngA
        End If
    End With
  End If
Next i
Range("AA1").CurrentRegion.Clear
Application.ScreenUpdating = True
End Sub

Es sollten keine Spaltenüberschriften gleich benannt sein.

Anbei Deine Beispieldatei mit dem angepasstem Code.



  MsOfficeFrage.xlsm (Größe: 62,03 KB / Downloads: 2)

[BoskoBiati]

Hallo,

ich würde es so machen:

Code:

Option Explicit

Private Sub worksheet_activate()
Dim loA As Long
Dim loLetzte As Long
Dim loLetzte2 As Long
Dim rng As Range
Dim wks As Worksheet
loLetzte2 = 7
Set wks = Sheets("Gesamtübersicht")
wks.Range("C:J").Clear
Application.ScreenUpdating = False
For loA = 1 To Sheets.Count
    If Sheets(loA).Name <> "Gesamtübersicht" Then
        With Sheets(loA)
            loLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
            If loLetzte < 7 Then loLetzte = 7
            Set rng = .Range("C7:J" & loLetzte)
            rng.Copy wks.Cells(loLetzte2 + 1, 3)
            loLetzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row
            If loLetzte2 < 7 Then loLetzte2 = 7
        End With
    End If
    Next
    
    Set rng = wks.Range("C7:J" & loLetzte2)
    Range("C8") = rng.Sort(Range("E8"), xlDescending, Range("c8"), , xlAscending)
    With Range("E8:E9999")
    .Value = .Value
    End With
    loLetzte2 = Cells(Rows.Count, 5).End(xlUp).Row + 1
    Range("C" & loLetzte2 & ":J900000").Clear
    
    
    Application.ScreenUpdating = True
    
End Sub

[atilla]

Hallo Edgar,

keine schlechte Idee aber

1.  vielleicht wäre es sinnvoll, vorher mit Zählenwenn() zu prüfen, ob überhaupt ein Treffer zu erwarten ist,
2.  sollte auch geprüft werden ob genügend Zeilen vorrätig sind.

[BoskoBiati]

Hallo atilla,


kann man machen:

Code:

Option Explicit

Private Sub worksheet_activate()
Dim loA As Long
Dim loLetzte As Long
Dim loletzte2 As Long
Dim rng As Range
Dim wks As Worksheet
loletzte2 = 7
Set wks = Sheets("Gesamtübersicht")
wks.Range("C:J").Clear
Application.ScreenUpdating = False
For loA = 1 To Sheets.Count
    If Sheets(loA).Name <> "Gesamtübersicht" Then
        If Application.WorksheetFunction.CountIf(Sheets(loA).Range("E:E"), "prüfen") <> 0 Then
            With Sheets(loA)
                loLetzte = .Cells(Rows.Count, 3).End(xlUp).Row
                If loLetzte < 7 Then loLetzte = 7
                Set rng = .Range("C7:J" & loLetzte)
                rng.Copy wks.Cells(loletzte2 + 1, 3)
                loletzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row + 1
                If loletzte2 < 7 Then loletzte2 = 7
                If loletzte2 > 60000 Then
                    sortieren
                    loletzte2 = wks.Cells(Rows.Count, 3).End(xlUp).Row + 1
                End If
            End With
        End If
    End If
Next
    sortieren
    Application.ScreenUpdating = True
    
End Sub
Sub sortieren()
Dim wks As Worksheet
Dim rng As Range
Dim loLetzte As Long
Set wks = Sheets("Gesamtübersicht")
loLetzte = Cells(Rows.Count, 5).End(xlUp).Row

Set rng = wks.Range("C7:J" & loLetzte)
    rng.Sort key1:=Range("E7"), order1:=xlDescending, key2:=Range("c7"), order2:=xlAscending
    With Range("E7:E9999")
    .Value = .Value
    End With
    loLetzte = Cells(Rows.Count, 5).End(xlUp).Row + 1
    Range("C" & loLetzte & ":J900000").Clear
    
End Sub