Option Explicit
Sub TestIt()
Dim rngUsed As Range
Dim lngFirst As Long, lngLast As Long
Dim lngMax As Long, lngChoise As Long
Dim rngList As Range, rngChoise As Range
Dim idx() As Long
Dim varRnd() As Variant
Dim arrRow() As Variant
Dim i As Long, j As Long
Dim blnUnique As Boolean
On Error GoTo fail
Set rngUsed = ActiveSheet.UsedRange
lngLast = rngUsed.Rows(rngUsed.Rows.Count).Row
lngFirst = CLng(InputBox("Erste Zeile der Tabelle = ", "Abfrage"))
If lngFirst < 1 Or lngFirst >= lngLast Then Err.Raise 513
lngMax = lngLast - lngFirst + 1
lngChoise = CLng(InputBox("Wahle Anzahl aus " & CStr(lngMax), "Abfrage"))
If lngChoise < 1 Or lngChoise >= lngMax Then Err.Raise 513
Set rngChoise = Application.InputBox("Klicke in Auswahl(Spalte)", _
"Abfrage Kriterium", , , , , , 8)
If Intersect(rngChoise, rngUsed) Is Nothing Then Err.Raise 513
Set rngList = Cells(lngFirst, rngChoise.Column).Resize(lngLast, 1)
ReDim idx(1 To lngChoise)
ReDim varRnd(1 To lngChoise)
ReDim arrRow(1 To lngChoise)
For i = 1 To lngChoise
Do
blnUnique = True
idx(i) = Int(lngMax * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
blnUnique = False
Exit For
End If
Next j
If blnUnique = True Then
Exit Do
End If
Loop
varRnd(i) = rngList.Cells(idx(i), 1)
arrRow(i) = rngList.Cells(idx(i), 1).Row
Next i
Select Case MsgBox("ausgewählt:" & Chr(10) & Join(varRnd, Chr(10)), vbYesNo, _
"Soll verteilt werden?")
Case vbYes
For i = LBound(arrRow) To UBound(arrRow)
rngUsed.Rows(arrRow(i)).Font.Bold = True
rngUsed.Rows(arrRow(i)).Font.ColorIndex = 3
rngUsed.Rows(arrRow(i)).Copy rngUsed.Cells(1).Offset(lngLast + 1 + i)
rngUsed.Rows(arrRow(i)).ClearContents
Next i
rngUsed.Font.Italic = True
Set rngUsed = ActiveSheet.UsedRange
lngLast = rngUsed.Rows(rngUsed.Rows.Count).Row
For j = lngLast To 1 Step -1
If Application.CountA(Cells(j, 1).EntireRow) = 0 Then Rows(j).Delete
Next j
End Select
On Error GoTo 0
fail:
Select Case Err.Number
Case 0
Case 13, 513, 424
Call MsgBox("Fehlerhafte Eingabe", vbOKOnly + vbCritical, "Abbruch")
End Select
End Sub