Filtern uns gefilterte Daten kopieren

Sub FilternUndKopieren() Dim rngAct As Range With Worksheets("Tabelle1").Range("A8") .AutoFilter Field:=20, Criteria1:=Range("U1") Set rngAct = Range("C8:C1000") rngAct.Copy Worksheets("Tabelle2").Range("B8") End With ActiveSheet.AutoFilterMode = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter,
genau das macht mein Code, allerdings hast du in deinem ersten Post geschrieben
"Der in Tabelle1 Zelle U1 eingegebene Wert wird in Spalte 20 gefiltert"
und Spalte 20 ist nun mal "T".
Jetzt schreibst du "In Spalte U wird nun über den Autofilter die ID-Nummer ausgefiltert", und das ist Spalte 21.
Hab den Code jetzt mal auf Spalte "U" angepasst.
Sub FilternUndKopieren()
    Dim vTmp() As Variant, vCopy As Variant
    Dim lngR As Long, lngIndex As Long

    With Worksheets("Tabelle1")
        vCopy = .Range("C8:U" & Application.Max(.Cells(Rows.Count, 20).End(xlUp).Row, 8))
    End With

    With Worksheets("Tabelle2")

        For lngR = 1 To UBound(vCopy, 1)
            If vCopy(lngR, 19) = Sheets("Tabelle1").Range("U1") Then
                If IsError(Application.Match(vCopy(lngR, 1), .Range("B:B"), 0)) Then
                    Redim Preserve vTmp(lngIndex)
                    vTmp(lngIndex) = vCopy(lngR, 1)
                    lngIndex = lngIndex + 1
                End If
            End If
        Next

        If lngIndex > 0 Then
            lngR = Application.Max(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 8)
            .Range(.Cells(lngR, 2), .Cells(lngR + UBound(vTmp), 2)) = Application.Transpose(vTmp)
        End If

    End With

End Sub

Gruß Sepp

Hallo Peter,
eine Spaltenanpassung war falsch. Jetzt sollte es laufen.
Sub FilternUndKopieren()
    Dim vTmp() As Variant, vCopy As Variant
    Dim lngR As Long, lngIndex As Long

    With Worksheets("Tabelle1")
        vCopy = .Range("C8:U" & Application.Max(.Cells(Rows.Count, 21).End(xlUp).Row, 8))
    End With
    'schreibt die Daten aus dem Bereich "C8:U bis zur letzten gefüllten Zeile in Spalte "U" in ein Array

    With Worksheets("Tabelle2")

        For lngR = 1 To UBound(vCopy, 1) 'Zeilen des Arrays durchlaufen
            If vCopy(lngR, 19) = Sheets("Tabelle1").Range("U1") Then
                'wenn der Wert der letzten Spalte des Array = Eintrag in Tabelle1!U1 dann
                If IsError(Application.Match(vCopy(lngR, 1), .Range("B:B"), 0)) Then
                    'wenn der Wert aus der ersten Spalte des Arrays (aus Tabelle1!Cx) nicht
                    'in Spalte "B" der Tabelle2 enthalten dann
                    Redim Preserve vTmp(lngIndex)
                    vTmp(lngIndex) = vCopy(lngR, 1)
                    lngIndex = lngIndex + 1
                    'Wert in temporäres Array schreiben
                End If
            End If
        Next

        If lngIndex > 0 Then
            'wenn Daten im temporären Array dann
            lngR = Application.Max(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 8)
            .Range(.Cells(lngR, 2), .Cells(lngR + UBound(vTmp), 2)) = Application.Transpose(vTmp)
            'Array in Spalte "B" von Tabelle2 schreiben. Unterhalb der bestehenden Daten.
        End If

    End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Filtern uns gefilterte Daten kopieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread