sitze nun schon mehrere Nächte und schaffe es nicht ....
Sollte in Angefügter Tabelle mit Filter den Datenbereich aus der Spalte S wenn Wert"1" vorkommt Filtern und das Ergebnis nach Tabelle zwei kopieren...
jedoch bin ich jetzt daraufgekommen das es mit Autofilter nicht funktioniert.....nur ca.1000 Datensätze werden gefiltert.....
es können aber 10000 sein.......habe jetzt soviel über spezialfilter gelesen das ich mich gar nicht mehr auskenne ....
bitte !!!!!
gruss Johann
Im Anhang mein bisheriger Code und die Beispieltabelle:
bin nicht immer online heute ...
Sub Create_Filter()
'Datenbereich finden (Hintergrundfarbe 37)
On Error Resume Next
'Chance ausschalten
Application.EnableEvents = Not Application.EnableEvents
ActiveSheet.Range("A24").Select
For ActRow = 1 To 640000
If ActiveCell.Offset(ActRow, 0).Interior.ColorIndex <> 37 Then Exit For
Next ActRow
If ActRow = 1 Then
MsgBox ("Achtung: Keine Daten vorhanden!")
Exit Sub
End If
On Error Resume Next
'Datenbereich hier sind noch alle Datensätze vorhanden und Korrekt !!
PtWdata = "Tabelle1!R24C1:R" & Trim(Str(24 + ActRow - 1)) & "C19"
'Arbeitsmappe auslesen mit Kriterium "Tabelle1"
Application.DisplayAlerts = False
Dim wks As Worksheet
For Each wks In Sheets
If wks.Name = "Tabelle1" Then Selection.AutoFilter Field:=19, Criteria1:="1"
Next
Application.DisplayAlerts = True
ActiveSheet.Range("A24").Select
Rows(Zeile).Hidden = False
For ActRow = 1 To 640000
If ActiveCell.Offset(ActRow, 0).Interior.ColorIndex <> 37 Then Exit For
Next ActRow
If ActRow = 1 Then
MsgBox ("Achtung: Keine Daten vorhanden!")
Exit Sub
End If
On Error Resume Next
'Hier sollte nur noch der gefilterte Bereich herauskommen !!!!
PtWdata2 = "Tabelle1!R24C1:R" & Trim(Str(24 + ActRow - 1)) & "C19"
'Hier bekomme ich statt 12 Datensätzen (PtWdata) alle zurück so als wenn der
'Autofilter nicht eingeschaltet wäre !!!!
'Oder müsste ich das mit Sortieren machen ...da weiß ich allerdings nicht wie
'ich den datenbereich ausrechnen soll ????
PtWdata.Select
PtWdata.Copy
Sheets("Tabelle2").Select
Rows("24:24").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Tabelle1").Select
Application.CutCopyMode = False
End Sub