Sub DoIt()
Dim rngNum As Range, c As Range
With Sheets("Tabelle3")
.Unprotect
.Cells.Clear
End With
With Sheets("Tabelle1")
.Activate
On Error Resume Next
Set rngNum = Application.InputBox("Klicke auf Nummern-Zelle", "Zur Weiterverarbeitung", , , , , , 8)
If Err.Number > 0 Then Exit Sub
On Error GoTo 0
If rngNum.Column <> 2 Or rngNum.Value = "" Or Not IsNumeric(rngNum.Value) Then Exit Sub
End With
With Sheets("Tabelle2")
.Columns(2).AutoFilter Field:=1, Criteria1:=rngNum.Value
.UsedRange.SpecialCells(12).Copy Sheets("Tabelle3").Cells(1)
.Columns(2).AutoFilter
End With
With Sheets("Tabelle3")
Do While .Cells(2).Value <> rngNum.Value
.Cells(2).EntireRow.Delete
Loop
Set rngNum = .Cells(2).Offset(3)
Do
Range(rngNum.Offset(1, 0), rngNum.Offset(2, 0)).EntireRow.Insert
Set rngNum = rngNum.Offset(3)
If rngNum.Offset(1, 0) = "" Then Exit Do
Loop
.Cells.Locked = False
.Columns("A:F").Locked = True
End With
Sheets("Tabelle3").Activate
End Sub