# sbRandHistogrm

Create a histogram distribution of random numbers
`Function sbRandHistogrm(dmin As Double, dMax As Double, _            vWeight As Variant, Optional dRandom = 1#) As Double'Specifies a histogram distribution with 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.'Similar to @Risk's function RiskHistogrm.'18-Oct-2020 V1.01 (C) (P) by Bernd Plumhoff'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm​Dim i As Long, n As Long, vW As VariantDim dRand As Double, dR As Double, dSumWeight As Double​With Application.WorksheetFunctionvW = .Transpose(.Transpose(vWeight))End With​n = UBound(vW)ReDim dSumWeightI(0 To n) As Double   dSumWeight = 0#dSumWeightI(0) = 0#For i = 1 To n    If vW(i) < 0# Then 'A negative weight is an error        sbRandHistogrm = CVErr(xlErrValue)        Exit Function    End If    dSumWeight = dSumWeight + vW(i) 'Calculate sum of all weights    dSumWeightI(i) = dSumWeight     'Calculate sum of weights till iNext i​If dSumWeight = 0# Then  'Sum of weights has to be greater than zero    sbRandHistogrm = CVErr(xlErrValue)    Exit FunctionEnd If​If dRandom = 1# Then    dRand = Rnd()Else    dRand = dRandomEnd IfdR = dSumWeight * dRand​i = nDo While dR < dSumWeightI(i)    i = i - 1Loop​sbRandHistogrm = dmin + (dMax - dmin) * _     (CDbl(i) + (dR - dSumWeightI(i)) / vW(i + 1)) / CDbl(n)​End Function`
`Enum book_info_columns    bicNumber = 1    bicCount    bicTitle    bicStats = 7End Enum​Enum some_stats    statsCheck = 0    statsRest    statsMinGroup    statsAvgGroup    statsMaxGroup    statsUBoundEnd Enum​Sub CreateGroups()'Creates random groups of books with specified group size and specified number of books per title.'Tries to use up all books.'This sub needs (calls) UDF sbRandHistogrm.'(C) (P) Bernd Plumhoff, v0.3 19-Oct-2020'Source: https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrmDim i As Long, j As Long, lBooks As Long, lGroups As Long, lSize As Long, lTotal As LongDim dMax As DoubleDim vI As Variant, vT As Variant'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/classes/systemstateDim state As SystemState​With Application.WorksheetFunctionSet state = New SystemState 'Speed up VBA​'First part - Read in book information and group sizevI = Range(wsI.Cells(2, bicNumber), wsI.Cells(1, bicTitle).End(xlDown))lSize = Range("GroupSize")​'Second part - Create groupsRandomizelBooks = UBound(vI, 1)lTotal = .Sum(.Index(.Transpose(vI), bicCount))ReDim lOut(1 To lSize, 1 To lTotal \ lSize) As LongReDim lStats(1 To lBooks, 0 To statsUBound - 1) As LongDo While CountNonZero(vI) >= lSize 'As long as we can fill a group we continue    lGroups = lGroups + 1    dMax = .Max(.Index(.Transpose(vI), bicCount))    vT = .Index(.Transpose(vI), bicCount)    For i = LBound(vT) To UBound(vT)        'Exponentially scaled weights are better than linear ones        If vT(i) > 0# Then vT(i) = Exp(vT(i) / dMax * 5#) 'Change 5# if necessary    Next i    For i = 1 To lSize        'See https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/sbrandhistogrm        j = Int(sbRandHistogrm(1#, CDbl(lBooks) + 1#, vT))        vT(j) = 0 'This book must not reappear in this group        lOut(i, lGroups) = j        vI(j, bicCount) = vI(j, bicCount) - 1        lStats(j, statsCheck) = lStats(j, statsCheck) + 1        lStats(j, statsAvgGroup) = lStats(j, statsAvgGroup) + lGroups        If lStats(j, statsMinGroup) = 0 Then lStats(j, statsMinGroup) = lGroups        lStats(j, statsMaxGroup) = lGroups    Next iLoopIf lGroups = 0 Then    Call MsgBox("No group. Number of books is too small or size of groups too large.", vbOKOnly, "Error")    Exit SubEnd IfReDim Preserve lOut(1 To lSize, 1 To lGroups) As Long​'Third part - Fill output sheetwsO.Cells.ClearContentsRange(wsO.Cells(1, 1), wsO.Cells(lGroups, lSize)).FormulaArray = .Transpose(lOut)​'Fourth part - some statistics to reassure the user that we got a good mix and used up as many books as possibleFor i = 1 To lBooks    lStats(i, statsRest) = vI(i, bicCount)    lStats(i, statsAvgGroup) = lStats(i, statsAvgGroup) \ lStats(i, statsCheck)Next iRange("GroupsGenerated") = lGroupsRange(wsI.Cells(2, bicStats + statsCheck), wsI.Cells(1 + lBooks, bicStats + statsUBound - 1)).FormulaArray = lStats​Set state = Nothing 'Not even necessary - will be done automaticallyEnd WithEnd Sub​Function CountNonZero(v As Variant) As LongDim i As Long, n As LongFor i = LBound(v, 1) To UBound(v, 1)    If v(i, bicCount) <> 0 Then n = n + 1Next iCountNonZero = nEnd Function`