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
Set wksEingabe = ThisWorkbook.Worksheets("Eingabe")
Set wksTeile = ThisWorkbook.Worksheets("Teile")
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
.AutoFilterMode = False
End With
End Sub