Bräuchte Hilfe bei unten angefügten Code....bitte!
Habe 5 Tabellen und bei Tabelle 1 rechne ich ab einer bestimmten
Zeile die Anzahl von Datensätzen aus und setzte einen Filter auf 1.
Muss nun nach dem setzen des Filters die Anzahl der Datensätze neu berechnen ......und das neue Ergebniss in Tabelle 2 kopieren und zurückkehren.
a) Der Filter funktioniert zwar .......aber er rechnet die falsche Anzahl an Daten (PtwData)
b) nach der Selection funktioniert das kopieren nicht..
bitte hat wer eine Idee ??
Code:
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
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 !!!!
PtWdata = "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