Weighted Random sequence generation

[Bebbspoke]

I wish to create an adjustable weighted random sequence of 1’s & 0’s for (say) 100 rows of a single column.

Example – if the weight factor was (say) 65% then there would be 65 = 1’s and 35 = 0’s but the sequence down the column would be in random order…

Thank you in advance for your suggestions, sincerely, Bebbspoke

 

[MickG]

Try this for results in column "A":-
Nb:- Weight in code !!!

[COLOR="Navy"]Sub[/COLOR] MG25Mar44
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Ray(1 To 100), n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRay()
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRdn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
Const wt = 60
[COLOR="Navy"]For[/COLOR] n = 1 To 100
    Ray(n) = IIf(n <= wt, 1, 0)
[COLOR="Navy"]Next[/COLOR] n
  ReDim nRay(1 To UBound(Ray))
                Randomize
    [COLOR="Navy"]Do[/COLOR] Until c = 100
        nRdn = Int(Rnd * 100) + 1
        [COLOR="Navy"]If[/COLOR] Not Ray(nRdn) = vbNullString [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            nRay(c) = Ray(nRdn)
            Ray(nRdn) = vbNullString
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Loop[/COLOR]
Range("A1").Resize(100) = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Bebbspoke]

Thanks Mick for your macro - duly imported & tested... it's ages since I used VB or macros... is there any way I can get the macro to reference worksheet cells such that I can have the weight factor (Const wt = 60) and string length as variables? ... or am I asking the impossible? Thanks again, Bebbspoke.

 

[MickG]

Try this:-
Number of rows in "B1".
Weight in "C1".
Results column "A".

[COLOR="Navy"]Sub[/COLOR] MG25Mar25
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Ray(), n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Wt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRay()
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRdn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
Wt = Range("C1").Value: Rw = Range("B1").Value
   ReDim Ray(1 To Rw)
[COLOR="Navy"]For[/COLOR] n = 1 To Rw
    Ray(n) = IIf(n <= Wt, 1, 0)
[COLOR="Navy"]Next[/COLOR] n
ReDim nRay(1 To UBound(Ray))
    Randomize
    [COLOR="Navy"]Do[/COLOR] Until c = 100
        nRdn = Int(Rnd * Rw) + 1
        [COLOR="Navy"]If[/COLOR] Not Ray(nRdn) = vbNullString [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            nRay(c) = Ray(nRdn)
            Ray(nRdn) = vbNullString
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Loop[/COLOR]
Range("A1").Resize(Rw) = Application.Transpose(nRay)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[mikerickson]

You could use this UDF. If you want 65%, put .65 in B1

Select A1:A100 and enter the array formula =TRANSPOSE(RandomizeBinarySequence(100, 100*B1)) with Ctrl-Shift-Enter
If you want to re-calculate the randomization, use the ReCalcTrigger like
=TRANSPOSE(RandomizeBinarySequence(100, 100*B1, C1)) so that it re-calculates every time that C1 is changed.

Function RandomizeBinarySequence(TotalCount As Long, CountOfOnes As Long, Optional ReCalcTrigger As Variant) As Variant
    Dim Result() As Long
    Dim i As Long, temp As Long, randIndex As Long
    ReDim Result(1 To TotalCount)
    For i = 1 To CountOfOnes
        Result(i) = 1
    Next i
    
    Randomize
    For i = 1 To TotalCount
        randIndex = Int(Rnd() * TotalCount) + 1
        temp = Result(i)
        Result(i) = Result(randIndex)
        Result(randIndex) = temp
    Next i
    RandomizeBinarySequence = Result
End Function

 

[mikerickson]

I think this will be a faster randomize of the array

Function RandomizeBinarySequence2(totalCount As Long, countOfOnes As Long, Optional ReCalc As Variant) As Variant
    Dim Result() As Long
    Dim i As Long, randIndex As Long
    If totalCount < countOfOnes Then RandomizeBinarySequence2 = CVErr(xlErrNum)
    ReDim Result(1 To totalCount)
    
    Randomize
    For i = 1 To countOfOnes
        randIndex = Int(Rnd() * totalCount) + 1
        Do Until Result(randIndex) = 0
            randIndex = (randIndex Mod totalCount) + 1
        Loop
        Result(randIndex) = 1
    Next i
    RandomizeBinarySequence2 = Result
End Function

 

[Bebbspoke]

Hi Mike - 'fraid you're losing me with your UDF methodology - I'm v. much a newbie with VB etc,

 

[mikerickson]

Try this approach. With the number of cells in B1 and the weight in C1. e.g. 100 in B1 and .65 in C1

Sub Test()
    Dim RowSize as Long, PctOnes as Double
    RowSize = Range("B1").Value
    PctOnes = Range("C1").Value

    Range("A1").Resize(RowSize, 1).Value = Application.Transpose(RandomizedBinarySequence(RowSize, RowSize * PctOnes))
End Sub

Function RandomizeBinarySequence2(totalCount As Long, countOfOnes As Long, Optional ReCalc As Variant) As Variant
    Dim Result() As Long
    Dim i As Long, randIndex As Long
    If totalCount < countOfOnes Then RandomizeBinarySequence2 = CVErr(xlErrNum)
    ReDim Result(1 To totalCount)
    
    Randomize
    For i = 1 To countOfOnes
        randIndex = Int(Rnd() * totalCount) + 1
        Do Until Result(randIndex) = 0
            randIndex = (randIndex Mod totalCount) + 1
        Loop
        Result(randIndex) = 1
    Next i
    RandomizeBinarySequence2 = Result
End Function

 

[Bebbspoke]

Hi Mike; - thank you for your efforts - I regret I cannot get them to run - I'm sure it's simply newbie incompetence...
I copy & paste the entire script into a (new) module but when I attempt to run it; - it freezes at; -
[FONT=&quot]Range("A1").Resize(RowSize,1).Value = Application.Transpose(RandomizedBinarySequence(RowSize, RowSize * PctOnes))

I assume (perhaps(?) I should import the Sub routine & the Function as separate entities... or, please; - where am I going wrong?

Apologies for appearing such an idiot, but some further guidance would be much appreciated, thank you.[/FONT]

 

[mikerickson]

What values are in B1 and C1?