Verteilung - VBA Lösung gesucht | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim arrWert Dim arrTeil Dim Anzahl As Long Dim SummeTeil As Single Dim i As Long, j As Long, k As Long Dim arrErg() arrWert = Array("A", "B", "C", "D", "E", "F") arrTeil = Array(20, 10, 20, 20, 20, 10) For i = 0 To UBound(arrTeil) SummeTeil = SummeTeil + arrTeil(i) Next Anzahl = 100 ReDim arrErg(1 To Anzahl, 1 To 1) For i = 0 To UBound(arrWert) For j = 1 To Anzahl * arrTeil(i) / SummeTeil k = k + 1 arrErg(k, 1) = arrWert(i) Next Next Range("A1").Resize(Anzahl, 1) = arrErg End Sub

Auch Hallo,
sowas vielleicht?
cu, Bernd
--

Option Explicit

Sub x()
    Dim arWerte As Variant, arTeile As Variant, arZufall(1 To 100) As Variant
    Dim i As Integer, j As Integer, k As Integer, intZufall As Integer

    arWerte = Array("A", "B", "C")
    arTeile = Array(80, 19, 1)

    If UBound(arWerte) <> UBound(arTeile) Then Exit Sub

    For i = 0 To UBound(arTeile)
        For j = 1 To arTeile(i)
            k = k + 1
            If k > 100 Then
                MsgBox "Njet"
                Exit Sub
            End If
            arZufall(k) = arWerte(i)
        Next
    Next
    For i = 1 To 1000
        intZufall = Int(100 * Rnd() + 1)
        Cells(i, 1).Value = arZufall(intZufall)
    Next
End Sub

Hallo Bernd,
Danke für den Code.
Aber ich möchte eben nicht über Random gehen, sondern die Werte möglichst gleichverteilen.
Ich hab mir in der Zwischenzeit die folgende Lösung gebastelt. Da gibt es je nach Zahlen-Kombination natürlich erhebliche Abweichungen, aber eine Zelle kann eben nur einmal besetzt werden.
Vielleicht hat ja noch jemand ne bessere Idee, aber erst mal danke an dich und Daniel.
Gruß
Chris


Sub Verteilung()
Dim arrWert, arrTeil
Dim i As Integer, j As Integer, k As Integer
Dim tmp1 As Integer, tmp2 As String
arrWert = Array("A", "B", "C", "D", "E", "F")
arrTeil = Array(5, 50, 5, 10, 10, 20)
k = 4
'sortieren - größte zuerst
For i = 0 To UBound(arrTeil)
For j = i To UBound(arrTeil)
If arrTeil(j) > arrTeil(i) Then
tmp1 = arrTeil(i)
tmp2 = arrWert(i)
arrTeil(i) = arrTeil(j)
arrWert(i) = arrWert(j)
arrTeil(j) = tmp1
arrWert(j) = tmp2
End If
Next
Next
Range("A1:G1000").Clear
For i = 1 To 500
For j = 0 To UBound(arrTeil)
If arrTeil(j) > 0 Then
If (i - 1) Mod Int(100 / arrTeil(j)) = j Then
Cells(k, 1) = arrWert(j)
Cells(k, j + 2) = arrWert(j)  'nur zur Demo
k = k + 1
End If
End If
Next
Next
End Sub

Beliebteste Forumthreads (12 Monate)

Verteilung - VBA Lösung gesucht

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread