“Chance favours the prepared mind.” [Louis Pasteur]

Abstract

Es ist recht leicht, einen “unfairen” Würfel zu simulieren. Wenn wir z. B. im Mittel die 6 doppelt so häufig wie alle anderen Zahlen 1 bis 5 erhalten wollen, geben Sie in Zelle A1 ein: =MIN(GANZZAHL(ZUFALLSZAHL()*7+1);6)

Aber wenn Sie einen Würfel 7 mal würfeln wollen und alle Zahlen von 1 bis 5 genau einmal und die 6 genau zweimal erscheinen soll?

Hier ist meine allgemeine Lösung:

sbExactRandHistogrm

Die Excel / VBA Funktion sbExactRandHistogrm

Name

sbExactRandHistogrm – Erzeuge eine exakte Histogramm-Verteilung des Datentyps Double.

Synopsis

sbExactRandHistogrm(ldraw; dmin; dmax; vWeight)

Description

sbExactRandHistogrm erzeugt eine exakte Histogramm-Verteilung für ldraw Ziehungen von Gleitkommazahlen mit doppelter Genauigkeit im Intervall dmin:dmax. Dieses Intervall ist in vWeight.count Klassen unterteilt. Jede Klasse besitzt das Gewicht vWeight(i), welches die Wahrscheinlichkeit des Erscheinens eines Wertes innerhalb dieser Klasse darstellt. Wenn die Gewichte nicht genau für ldraw Ziehungen erreicht werden können, dann wird das Hare-Niemeyer-Verfahren (“Quotenverfahren mit Restausgleich nach größten Bruchteilen”) angewandt, um den absoluten Fehler zu minimieren. Diese Funktion benötigt (ruft auf) RoundToSum.

Parameter

ldraw – Anzahl der Ziehungen

dmin – Minimum = Untergrenze für die zu ziehenden Zahlen

dmax – Maximum = Obergrenze für die zu ziehenden Zahlen

vWeight – Array von Gewichten. Die Array Grüße bestimmt die Anzahl der Klassen, in die das Intervall dmin : dmax aufgeteilt wird. Die Array Werte bestimmen die Wahrscheinlichkeit, mit der Werte innerhalb dieser Klasse gezogen werden.

Siehe Auch

RoundToSum

Appendix – Programmcode sbRandHistogrm

Bitte beachten dass sbRandHistogrm RoundToSum benötigt und aufruft.

Bitte den Haftungsausschluss im Impressum beachten.

Function sbExactRandHistogrm(ldraw As Long, _
            dmin As Double, _
            dmax As Double, _
            vWeight As Variant) As Variant
'Creates an exact histogram distribution for ldraw draws within range dmin:dmax.
'This range is divided into vWeight.count classes. Each class has weight vWeight(i)
'reflecting the probability of occurrence of a value within the class.
'If weights can't be achieved exactly for ldraw draws the largest remainder method will
'be applied to minimize the absolute error. This function calls (needs) sbRoundToSum.
'Source (EN): http://www.sulprobil.com/sbexactrandhistogrm_en/
'Source (DE): http://www.bplumhoff.de/sbexactrandhistogrm_de/
'(C) (P) by Bernd Plumhoff 01-May-2021 PB V0.9

Dim i As Long, j As Long, n As Long
Dim vW As Variant
Dim dSumWeight As Double, dR As Double

Randomize
With Application.WorksheetFunction
vW = .Transpose(vWeight)
On Error GoTo Errhdl
i = vW(1) 'Throw error in case of horizontal array
On Error GoTo 0

n = UBound(vW)
ReDim dWeight(1 To n) As Double
ReDim dSumWeightI(0 To n) As Double
ReDim vR(1 To ldraw) As Variant

For i = 1 To n
    If vW(i) < 0# Then 'A negative weight is an error
        sbExactRandHistogrm = CVErr(xlErrValue)
        Exit Function
    End If
    'Calculate sum of all weights
    dSumWeight = dSumWeight + vW(i)
Next i

If dSumWeight = 0# Then
    'Sum of weights has to be greater zero
    sbExactRandHistogrm = CVErr(xlErrValue)
    Exit Function
End If

For i = 1 To n
    'Align weights to number of draws
    dWeight(i) = CDbl(ldraw) * vW(i) / dSumWeight
Next i

vW = RoundToSum(dWeight, 0)
On Error GoTo Errhdl
i = vW(1) 'Throw error in case of horizontal array
On Error GoTo 0

For j = 1 To ldraw

    dSumWeight = 0#
    dSumWeightI(0) = 0#
    For i = 1 To n
        'Calculate sum of all weights
        dSumWeight = dSumWeight + vW(i)
        'Calculate sum of weights till i
        dSumWeightI(i) = dSumWeight
    Next i
    
    dR = dSumWeight * Rnd
    
    i = n
    Do While dR < dSumWeightI(i)
        i = i - 1
    Loop
    
    vR(j) = dmin + (dmax - dmin) * (CDbl(i) + _
            (dR - dSumWeightI(i)) / vW(i + 1)) / CDbl(n)
    vW(i + 1) = vW(i + 1) - 1#
    
Next j

sbExactRandHistogrm = vR

Exit Function

Errhdl:
'Transpose variants to be able to address
'them with vW(i), not vW(i,1)
vW = .Transpose(vW)
Resume Next
End With

End Function

Download

Bitte den Haftungsausschluss im Impressum beachten.

sbExactRandHistogrm.xlsm [32 KB Excel Datei, ohne jegliche Gewährleistung]