da das Thema "Wichteln" wieder im Umlauf ist, würde ich gerne per Zufallsprinzip Paare bilden.
Vielleicht könnt ihr mir dabei helfen dass dies per Klick ausgewertet wird.
https://www.herber.de/bbs/user/116685.xlsx
Vielen Dank.
Liebe Grüße
Amintire
Sub paare()
Dim lngRow As Long, lngCol As Long, lngRnd As Long, lngC As Long
Dim varIn As Variant, varOut() As Variant
If Application.CountA(Range("A4:A" & Application.Max(4, Cells(Rows.Count, 1).End(xlUp).Row))) < 2 Then
MsgBox "Zu wenige Namen!"
Else
varIn = Application.Transpose(Range("A4:A" & Application.Max(4, Cells(Rows.Count, 1).End(xlUp).Row)))
lngC = Int(UBound(varIn) / 2)
Redim Preserve varOut(1 To lngC, 1 To 2)
lngCol = 1
Randomize Timer
Do
lngRnd = Int((UBound(varIn)) * Rnd() + 1)
lngRow = lngRow + 1
If lngRow > lngC Then
lngRow = 1
lngCol = 2
End If
varOut(lngRow, lngCol) = varIn(lngRnd)
If UBound(varIn) = 1 Then Exit Do
varIn(lngRnd) = varIn(UBound(varIn))
Redim Preserve varIn(1 To UBound(varIn) - 1)
Loop
Range("C4").Resize(lngC, 2) = varOut
End If
End Sub