Random value assign with weightage

[avilashm]

[FONT=garamond, serif]I have a sample size of 30. I need an excel function in which I can assign " Random Values " (say a question has 4 options and need to assign 1 to 4 randomly) based on the weight to each individual from the sample.[/FONT]
[FONT=garamond, serif]
[/FONT]
[FONT=garamond, serif]Means Option 1: 45%[/FONT]
[FONT=garamond, serif] Option 2: 12%[/FONT]
[FONT=garamond, serif] Option 3: 30%[/FONT]
[FONT=garamond, serif] Option 4: 13%[/FONT]
[FONT=garamond, serif]
[/FONT]
[FONT=garamond, serif]How to assign random values (1,2,3,4) with its respective percentages/weight.[/FONT]

 

[JoeMo]

This macro will produce results like those below using columns A & B. If there are sufficient "Trials" run the options will appear randomly, but in proportion to their respective weights.

Sub avilashm()
Dim OptionWeight(1 To 4), c As Variant, Trial As Variant
Const TrialsCount As Long = 100 'change to suit
Application.ScreenUpdating = False
Range("A:B").ClearContents
OptionWeight(1) = 0.45   'Change to suit
OptionWeight(2) = 0.12
OptionWeight(3) = 0.3
OptionWeight(4) = 0.13
If Evaluate(Join(OptionWeight, "+")) <> 1 Then
    MsgBox "Option weights must sum to 1 - try again"
    Application.ScreenUpdating = True
    Exit Sub
End If
Range("A1:B1").Value = Array("Trial No.", "Option No.")
For Each c In Range("B2:B" & TrialsCount + 1)
    Ct = Ct + 1
    c.Offset(0, -1).Value = Ct
Again:  Trial = Application.RandBetween(1, 4)
        If Application.CountIf(Range("B$1:B" & c.Row - 1), Trial) < TrialsCount * OptionWeight(Trial) Then
            c.Value = Trial
        Else
            GoTo Again
        End If
Next c
End Sub

Excel Workbook
	A	B	C	D	E	F	G
1	Trial No.	Option No.		1	2	3	4
2	1	3		45	12	30	13
3	2	2		0.45	0.12	0.3	0.13
4	3	1
5	4	1
6	5	2
7	6	3
8	7	3
9	8	1
10	9	1
11	10	3
12	11	4
13	12	3
14	13	4
15	14	1
16	15	2
17	16	4
18	17	2
19	18	1
20	19	1
21	20	4
22	21	4
23	22	1
24	23	2
25	24	2
26	25	1
Sheet9

 

[JoeMo]

After looking at this a bit more I modified it to get something that randomizes the weighted options without affecting the weights. This modification uses columns A:C. Replace the code in post #2 with this:

Sub avilashm()
Dim OptionWeight(1 To 4), c As Variant, Trial As Variant
Const TrialsCount As Long = 100 'change to suit
Application.ScreenUpdating = False
Range("A:C").ClearContents
OptionWeight(1) = 0.45   'Change to suit
OptionWeight(2) = 0.12
OptionWeight(3) = 0.3
OptionWeight(4) = 0.13
If Evaluate(Join(OptionWeight, "+")) <> 1 Then
    MsgBox "Option weights must sum to 1 - try again"
    Application.ScreenUpdating = True
    Exit Sub
End If
Range("A1:C1").Value = Array("Trial No.", "Option No.", "Temp")
For Each c In Range("B2:B" & TrialsCount + 1)
    Ct = Ct + 1
    c.Offset(0, -1).Value = Ct
Again:  Trial = Application.RandBetween(1, 4)
        If Application.CountIf(Range("B$1:B" & c.Row - 1), Trial) < TrialsCount * OptionWeight(Trial) Then
            c.Value = Trial
        Else
            GoTo Again
        End If
Next c
'random scramble of options
With Range("B1:C" & TrialsCount + 1)
    Randomize
    .Cells(2, 2).Formula = "= RAND()"
    With .Columns(2).Offset(1, 0).Resize(.Columns(2).Rows.Count - 1)
        .FillDown
        .Calculate
        .Value = .Value
    End With
    .Sort key1:=[C2], order1:=xlAscending, Header:=xlYes
    .Columns(2).ClearContents
End With
Application.ScreenUpdating = True
End Sub