Option Explicit
Private Sub CommandButton1_Click()
MoveIt Sheets("Tabelle1"), Sheets("Tabelle2")
End Sub
Sub MoveIt(ShFrom As Worksheet, ShTo As Worksheet)
Dim rngX As Range
Dim rngTo As Range
Dim rngMove As Range
Dim c As Range
Dim x As Long
On Error GoTo NIX
With ShFrom
With .Columns(1)
Set rngX = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False)
Set rngX = .Range(.Cells(5), rngX.Offset(1).End(xlUp))
Set rngX = rngX.Offset(1).Resize(rngX.Rows.Count - 1)
End With
End With
With ShTo
With .Columns(3)
Set rngTo = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False)
Set rngTo = rngTo.Offset(1)
End With
End With
For x = 1 To rngX.Cells.Count
If UCase(rngX.Cells(x).Value) = "X" Then
Set rngMove = rngX.Cells(x)
Range(rngMove.Offset(, 2), rngMove.Offset(, 12)).Copy rngTo
Set rngTo = rngTo.Offset(1)
End If
Next x
For x = rngX.Cells.Count To 1 Step -1
If UCase(rngX.Cells(x).Value) = "X" Then
Set rngMove = rngX.Cells(x)
Set c = Range(rngMove.Offset(, 2), rngMove.Offset(, 2).End(xlDown))
If c.Rows.Count > 616 Then
Set c = rngMove.Offset(, 2)
Else
Set c = c.Resize(c.Rows.Count + 1, 11)
End If
Set c = c.Resize(, 11)
Set c = c.Offset(1).Resize(c.Rows.Count + 1)
c.Copy rngMove.Offset(, 2)
rngMove.ClearContents
End If
Next x
On Error GoTo 0
NIX:
End Sub