Mehrere Sheets filtern

[excelgirl]

Hallo Community, 

Ich brauche dringend eure Hilfe, weil ich nach stundenlanger Foren Suche immer noch nichts geklappt hat.

- Ich habe eine Exceltabelle mit 12 Sheet

- Jedes dieser 12 Sheets ist gleich aufgebaut

- Wenn in der Spalte D "prüfen" steht, soll diese Zeile auf das 13. Sheet kopiert werden

-Die Liste wird andauernd aktualisiert, sodass sich die Liste im 13. Sheet auch aktualiseren sollte.

Vielen Dank im Voraus !

[Fennek]

Hallo,

Wenn man davon ausgeht, dass der Index der Monate 1-12 ist und das Ergebnis-sheet "Result" heist, könnte folgender Code helfen:

Sub excelgirl()
Dim ws as sheets
Dim rng as range
NSh = thisworkbook.sheets.count -1
MySuch = "Prüfen"

For i = 1 to nSh
With sheets(i).columns(4)
Set rng = .find(mySuch)
If not rng is nothing then

Zeile = rng.row
.cells(zeile) = "ok"
.rows(zeile).entirerow.copy
Lr = sheets("Result").range("a1").currentregion.rows.count +1
Sheets("Result").cells(lr,1).pastespecial
Application.cutcopymode = false
End if

Set rng = nothing
End with
Next
End sub

Das Makro ändert jeweils "Prüfen" in "ok", damit Zeilen nur einmal kopiert werden. Entweder muss der Makro regelmäßig von Hand gestartet werden, oder mit "application.onTime" in eine selbstaufrufende Schleife gelegt werden.

Mfg

[excelgirl]

Hallo,

erst einmal vielen Dank!

Ich habe jetzt den Code versucht. Bei der Zeile

With Sheets(i).Columns(4)

kommt ein Laufzeitfehler 40036 Anwendungs-oder objektdef. Fehler

[atilla]

Hallo,

1. bis welcher Spalte sind Daten vorhanden?
2. Sind Überschriften vorhanden?
3. wenn ja, sind die Überschriften in allen identisch?
4. kommt der gesuchte Wert "prüfen" nur einmal vor oder kann er mehrmals vorkommen?
5. Bei Fund, soll der Wert "prüfen" verändert werden oder bleibt an der Fundstelle alles so wie es war?

Das Aktualisieren würde ich beim betreten der Ergebnistabelle automatisch über das WorksheetActivate Ereignis anstoßen.

[excelgirl]

1. bis welcher Spalte sind Daten vorhanden?
- bis Spalte K


2. Sind Überschriften vorhanden?
Ja, außer in Spalte  A und B , diese sind komplett leer

3. wenn ja, sind die Überschriften in allen identisch?
Ja

4. kommt der gesuchte Wert "prüfen" nur einmal vor oder kann er mehrmals vorkommen?
kommt mehrmals vor 

5. Bei Fund, soll der Wert "prüfen" verändert werden oder bleibt an der Fundstelle alles so wie es war?
soll so bleiben

[Fennek]

Hallo,

Der Code unterstellt, dass der Sheet-Index von 1-12 existiert, falls nicht muss die for...next schleife in eine for'each.Schleife'umgesetz'werden. Eine Markierung der bereits kopierten Zeilen ist notwendig, damit Zeilen nicht doppelt kopiert werden, wie das umgesetz wird, ist beliebig.

Der Code'kopiert jedesmal nur den ersten Treffer, muss also mehrfach laufen. Dies kann auch im Programm erledigt werden:

Am Anfang:

Flag = false

In der if -Passage:

Flag = true

Und am Ende:

If flag then excelgirl



Mfg

[BoskoBiati]

Hallo,

wie heißen denn die Überschriften?

[atilla]

Hallo,

folgendes ist gegeben.

Die Tabelle, in die kopiert werden soll, heißt "Übersicht"

Dann folgenden Code hinter die Tabelle "Übersicht"

Code:

Private Sub Worksheet_Activate()
 Call aktualisieren
End Sub

und weiter folgenden Code in ein allgemeines Modul

Code:

Option Explicit

Sub aktualisieren()
 Dim i As Long
 Dim lngA As Long, lngZ As Long
 Dim strSuch As String
 Sheets("Ü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("D"), strSuch)
       If lngA > 0 Then
         Range("AA1") = Range("d1")
         Range("AA2") = strSuch
         .Range("C1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
           "AA1:AA2"), CopyToRange:=Range("AB1:AK1"), Unique:=False
         Range("AB2:AK" & lngA + 1).Copy Range("C" & lngZ)
         lngZ = lngZ + lngA
         End If
     End With
   End If
 Next i
 Range("AA1").CurrentRegion.Clear
 Application.ScreenUpdating = True
End Sub

Du kannst den Code manuell starten oder aber er wird automatisch bei Aktivierung der Tabelle "Übersicht" gestartet.

[excelgirl]

@ Attilla
Bei 

Range("C1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _

           "AA1:AA2"), CopyToRange:=Range("AB1:AK1"), Unique:=False


kommt ein Fehler


@Fennek
Was ist mit einer Schleife gemeint? 


@BoskoBiati von der Tabelle oder von den Sheets?

[excelgirl]

Abei eine Beispieldatei