Nun Radizzel,

für eine VBA Lösung sind deine Angaben zu dürftig. Deshalb nur als Anregung ZumZum ;)

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

Und: Datensicherung nicht vergessen!