Zufall pro Gruppe (mit VBA)
25.04.2013 00:19:12
Erich
Hi Andy,
probier mal
Option Explicit
Sub GruppenZufall() ' Liste ist sortiert nach Spalte A
Dim lngQ As Long, arQA, arQB, nn As Long, zz As Long
Dim stOrt() As String, arBis() As Long, ii As Long, jj As Long
Dim anzW As Long, lngZ As Long, zDup() As Long, zuf As Long
Dim tt As Long, arErg()
Const Proz As Long = 2 ' Auswahl von 2%
With Sheets("Tabelle1") ' Quelltabelle
lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row
arQA = .Cells(1, 1).Resize(lngQ)
arQB = .Cells(1, 2).Resize(lngQ)
End With
ReDim stOrt(1 To lngQ)
ReDim arBis(0 To lngQ)
nn = 1
stOrt(nn) = arQA(1, 1)
For zz = 2 To lngQ
If stOrt(nn) arQA(zz, 1) Then
arBis(nn) = zz - 1
nn = nn + 1
stOrt(nn) = arQA(zz, 1)
lngZ = lngZ + _
Application.RoundUp((arBis(nn - 1) - arBis(nn - 2)) * Proz / 100, 0)
End If
Next zz
arBis(nn) = lngQ
lngZ = lngZ + _
Application.RoundUp((arBis(nn) - arBis(nn - 1)) * Proz / 100, 0)
ReDim Preserve stOrt(1 To nn)
ReDim Preserve arBis(0 To nn)
ReDim arErg(1 To lngZ, 1 To 2)
zz = 0
Randomize
For ii = 1 To nn
anzW = arBis(ii) - arBis(ii - 1) - 1 ' Anz. Werte - 1
lngZ = Application.RoundUp(anzW * Proz / 100, 0) ' Anz. Stichprobe
ReDim zDup(1 To lngZ)
For jj = 1 To lngZ
zz = zz + 1
zuf = Int(anzW * Rnd() + arBis(ii - 1)) + 1
Do ' keine Dubletten
For tt = 2 To jj - 1
If zuf = zDup(tt - 1) Then Exit For
Next tt
zuf = Int(anzW * Rnd() + arBis(ii - 1)) + 1
Loop Until tt >= jj
arErg(zz, 1) = stOrt(ii) ' Ergebnis in Array
arErg(zz, 2) = arQB(zuf, 1)
Next jj
Next ii
Worksheets.Add Before:=Sheets(1) ' Ausgabe in neuer Zieltabelle
Cells(1, 1).Resize(UBound(arErg), 2) = arErg
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich