Nabend julian,

versuch mal folgendes nd sage mir, ob das hinkommt.

Bemerkung vorab:

Es wird zwar kopiert, aber noch nicht in Deiner gewünschten Reihenfolge - 

Ausserdem bin Ich bei einigen Dingen Deiner Programmlogik treugeblieben, sodass Du Dich recht schnell zurechtfinden solltest.

Sag Bescheid, wenn die Richtung stimmt - 

Option Explicit

Sub selbstcopy30()
    Dim wksDatenbank As Excel.Worksheet
    Dim wksEinstellungen As Excel.Worksheet
    Dim wksEingabe As Excel.Worksheet
    Dim wksTeile As Excel.Worksheet
    Dim rng As Excel.Range

    Dim u As Long, i As Long
    Dim numr As Variant, artikelnr As Variant, hoehe As Variant, Besch As Variant, besch2 As Variant, zartikelnr As Variant, zhoehe As Variant, anzahl As Variant, breite As Variant, laenge As Variant
    '
    Set wksEinstellungen = ThisWorkbook.Worksheets("Einstellungen")
    With wksEinstellungen
        artikelnr = .Range("B15").Value
        hoehe = .Range("B16").Value
    End With
    '
    Set wksDatenbank = ThisWorkbook.Worksheets("Datenbank")
    With wksDatenbank
        Besch = .Range("A1").Value
        besch2 = .Range("A2").Value
        breite = .Range("A3").Value
        laenge = .Range("A5").Value
        anzahl = .Range("A8").Value
        zartikelnr = .Range("A6").Value
        zhoehe = .Range("A4").Value
    End With
    '
    'Sheets("Eingabe").Select
    Set wksEingabe = ThisWorkbook.Worksheets("Eingabe")
    Set wksTeile = ThisWorkbook.Worksheets("Teile")
'    For i = 3 To 15
'        For u = 2 To 16
'            If wksEingabe.Cells(i, zartikelnr) = artikelnr Then
'                If wksEingabe.Cells(i, zhoehe) = hoehe Then
'                'länge
'                wksEingabe.Cells(i, laenge).Copy Destination:=wksTeile.Cells(u, 1)
'                'breite
'                wksEingabe.Cells(i, breite).Copy Destination:=wksTeile.Cells(u, 2)
'                '  ActiveSheet.Paste
'                wksEingabe.Cells(i, anzahl).Copy Destination:=wksTeile.Cells(u, 3)
'                'ActiveSheet.Paste
'                'beschreibung
'                wksEingabe.Cells(i, Besch).Copy Destination:=wksTeile.Cells(u, 9)
'                End If
'            End If
'        Next u
'    Next i
    'Sheets("Teile").Select
    With wksEingabe
        
        If .AutoFilterMode Then .AutoFilterMode = False
        
        Set rng = .Range("A2:J" & .Cells(.Rows.Count, 10).End(xlUp).Row)
        If rng.Rows.Count <= 1 Then MsgBox "Keine Daten vorhanden!": Exit Sub
        
            rng.AutoFilter Field:=3, Criteria1:=artikelnr
                rng.AutoFilter Field:=10, Criteria1:=hoehe
                
                If Not Intersect(rng, rng.Offset(1, 0), rng.SpecialCells(xlCellTypeVisible)) Is Nothing Then
                    Call Intersect(rng, rng.Offset(1, 0), rng.SpecialCells(xlCellTypeVisible)).Copy
                    With wksTeile
                        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
                        Application.CutCopyMode = False
                    End With
                End If
        
        'ShowAllData
        .AutoFilterMode = False
    End With
End Sub