Distribute known numbers into columns using VBA

L

Luthius

Active Member
Joined
Apr 5, 2011
Messages
324
I have 2 set of numbers that I would like to mix them.
My first set contains 15 numbers that I would like to combine with a set of 10 numbers and distribute them into colunms.
From the set of 15 numbers, the code will choose 9 numbers (randomly) and combine with 5 numbers from the set of 10 numbers (randomly). It will generate a new set of 15 numbers (9 from my first set combined with 05 of the second set of numbers).


I know that it will generate a huge quantity of group of 15 numbers combined, but I would like to delimite in the code, by input box or something.

1st Set with 15 unique Numbers (Range B2:P2)
2nd Set with 09 unique Numbers (Range B3:k3)

Distribution will occur starting on row number 5 and distributed from Column A to Column O.

Luthius
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Re: How to distribute known numbers into columns using VBA

How about this?

Code: 
Public Results As Object


Sub Main()
Dim S1() As Variant: S1 = Range("B2:P2").value
Dim S2() As Variant: S2 = Range("B3:K3").value
Dim Set1 As Object: Set Set1 = CreateObject("System.Collections.ArrayList")
Dim Set2 As Object: Set Set2 = CreateObject("System.Collections.ArrayList")
Dim Cnt1 As Integer: Cnt1 = 9
Dim Cnt2 As Integer: Cnt2 = 5


Set Results = CreateObject("System.Collections.ArrayList")
fillList Set1, S1
fillList Set2, S2


Do Until Cnt1 = 0 And Cnt2 = 0
    If Cnt1 = 0 Then
        Pop Set2, Cnt2
    ElseIf Cnt2 = 0 Then
        Pop Set1, Cnt1
    Else
        If Rnd() > 0.5 Then
            Pop Set1, Cnt1
        Else
            Pop Set2, Cnt2
        End If
    End If
Loop


Results.Sort
Range("A5").Resize(1, Results.Count).value = Results.toArray


End Sub


Sub Pop(xSet As Object, Cnt As Integer)
Dim r As Integer
Dim obj As Variant: obj = Null


If Cnt > 0 Then
    r = Int((xSet.Count - 1) * Rnd)
    obj = xSet.Item(r)
    xSet.removeat r
    Cnt = Cnt - 1
    Results.Add obj
End If


End Sub


Sub fillList(xSet As Object, ARR() As Variant)


For i = LBound(ARR, 1) To UBound(ARR, 2)
    xSet.Add ARR(1, i)
Next i


End Sub
 
Upvote 0
Re: How to distribute known numbers into columns using VBA

Fistly I would like to correct a mistake I made, instead 05 numbers choosen, the correct is 06 numbers.


Thank you for taking your time to assist me.
Unfortunately is not like that.


I'm talking about Combinatorics, or combination of numbers.
It means combining 9 numbers from the 1st set + 6 numbers from the 2nd set will generate a total of 3,268,760 groups of 15 numbers each. Excel formula Combin(25,15).


As I would like to reduce this quantity of groups, the choosen numbers from 1st and 2nd sets will be randomic because I will delimite the quantity of groups that will be generated instead all 3876.
For instance, If I want 10 unique groups of 15 numbers to be generated, when is randomic the choose of the set of number (9+6) everytime I generate them will not be the same groups.

Sorry for not explain it in a better way.
 
Last edited:
Upvote 0
Re: How to distribute known numbers into columns using VBA

Let me know if this is more like what you are looking for.

Code: 
Public Results As Object
Public Combos As Object


Sub Main()
Dim S1() As Variant: S1 = Range("B2:P2").value
Dim S2() As Variant: S2 = Range("B3:K3").value
Dim Set1 As Object: Set Set1 = CreateObject("System.Collections.ArrayList")
Dim Set2 As Object: Set Set2 = CreateObject("System.Collections.ArrayList")
Dim Cnt1 As Integer: Cnt1 = 9
Dim Cnt2 As Integer: Cnt2 = 6
Dim GroupSize As Integer: GroupSize = 10


Set Results = CreateObject("System.Collections.ArrayList")
Set Combos = CreateObject("System.Collections.ArrayList")
fillList Set1, S1
fillList Set2, S2


Do Until Cnt1 = 0 And Cnt2 = 0
    If Cnt1 = 0 Then
        Pop Set2, Cnt2
    ElseIf Cnt2 = 0 Then
        Pop Set1, Cnt1
    Else
        If Rnd() > 0.5 Then
            Pop Set1, Cnt1
        Else
            Pop Set2, Cnt2
        End If
    End If
Loop


Results.Sort
'Range("A5").Resize(1, Results.Count).value = Results.toArray
Combinations Results.Count - 1, GroupSize, 0, 0, ""
With Range("A5").Resize(Combos.Count, 1)
    .value = Application.Transpose(Combos.toarray)
    .TextToColumns DataType:=xlDelimited, comma:=True
End With


End Sub


Sub Combinations(item_Count As Integer, Grp As Integer, Index As Integer, Depth As Integer, Buffer As String)
Dim Prefix As String


For i = Index To item_Count
    Prefix = Buffer & Results.Item(i) & ","
    If Depth + 1 = Grp Then
        Combos.Add Prefix
    Else
        Combinations item_Count, Grp, i + 1, Depth + 1, Prefix
    End If
Next i


End Sub




Sub Pop(xSet As Object, Cnt As Integer)
Dim r As Integer
Dim obj As Variant: obj = Null


If Cnt > 0 Then
    r = Int((xSet.Count - 1) * Rnd)
    obj = xSet.Item(r)
    xSet.removeat r
    Cnt = Cnt - 1
    Results.Add obj
End If


End Sub


Sub fillList(xSet As Object, ARR() As Variant)


For i = LBound(ARR, 1) To UBound(ARR, 2)
    xSet.Add ARR(1, i)
Next i


End Sub
 
Upvote 0
Re: How to distribute known numbers into columns using VBA

Unfortunately not.
When I'm saying "10 unique groups of 15 numbers to be generated", means each group will have 15 elements, and there is no repetition of all elements between them.
Below a random example of 10 groups with 15 elements each:

Grp#1- 01-03-08-09-10-11-12-13-14-15-16-17-18-19-20
Grp#2- 01-02-04-09-10-11-12-13-14-15-16-17-18-20-23
Grp#3- 03-05-08-09-10-11-12-13-14-15-16-17-18-21-23
Grp#4- 01-02-06-09-10-11-12-13-14-15-16-17-18-21-25
Grp#5- 04-06-07-09-10-11-12-13-14-15-16-20-22-23-25
Grp#6- 03-04-06-09-10-11-12-13-14-15-16-21-22-23-25
Grp#7- 01-04-08-09-10-11-12-13-14-15-17-18-19-20-22
Grp#8- 02-03-07-09-10-11-12-13-14-15-17-18-19-21-25
Grp#9- 05-07-08-12-13-14-15-16-17-20-21-22-23-24-25
Grp#10- 11-12-13-14-15-16-17-18-19-20-21-22-23-24-25
 
Upvote 0
Re: How to distribute known numbers into columns using VBA

Try this one.

Code: 
Public Results As Object
Public Combos As Object
Public Set1 As Object
Public Set2 As Object
Public s1Size As Integer
Public s2Size As Integer
Public S1Copy As Object
Public S2Copy As Object


Sub Main()
Randomize
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim S1() As Variant: S1 = Range("B2:P2").value
Dim S2() As Variant: S2 = Range("B3:K3").value
Dim Sample As Object: Set Sample = CreateObject("System.Collections.ArrayList")


Dim Pick As Integer: Pick = 10
Dim GroupSize As Integer: GroupSize = 15
Dim rItem As Integer
Dim cnt1 As Integer: cnt1 = 10
Dim cnt2 As Integer: cnt2 = 7


s1Size = cnt1 - 1
s2Size = cnt2 - 1
Set Results = CreateObject("System.Collections.ArrayList")
Set Combos = CreateObject("System.Collections.ArrayList")
Set Set1 = CreateObject("System.Collections.ArrayList")
Set Set2 = CreateObject("System.Collections.ArrayList")
Set S1Copy = CreateObject("System.Collections.ArrayList")
Set S2Copy = CreateObject("System.Collections.ArrayList")
fillList Set1, S1
fillList Set2, S2


Set S1Copy = Set1.Clone
Set S2Copy = Set2.Clone


Do Until cnt1 = 0 And cnt2 = 0
    If cnt1 = 0 Then
        Pop Set2, cnt2
    ElseIf cnt2 = 0 Then
        Pop Set1, cnt1
    Else
        If Rnd() > 0.5 Then
            Pop Set1, cnt1
        Else
            Pop Set2, cnt2
        End If
    End If
Loop


Results.Sort
Combinations Results.Count - 1, GroupSize, 0, 0, ""


Do Until Pick = 0
    r = Int((Combos.Count - 1) * Rnd)
    Sample.Add Combos.Item(r)
    Combos.removeat r
    Pick = Pick - 1
Loop


With Range("A5").Resize(Sample.Count, 1)
    .value = Application.Transpose(Sample.toarray)
    .TextToColumns DataType:=xlDelimited, comma:=True
End With




Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub Combinations(item_Count As Integer, Grp As Integer, Index As Integer, Depth As Integer, Buffer As String)
Dim Prefix As String


For i = Index To item_Count
    Prefix = Buffer & Results.Item(i) & ","
    If Depth + 1 = Grp Then
        If checkSets(Prefix) Then
            Combos.Add Prefix
        End If
    Else
        Combinations item_Count, Grp, i + 1, Depth + 1, Prefix
    End If
Next i


End Sub


Function checkSets(Combo As String) As Boolean
Dim sc1 As Integer
Dim sc2 As Integer
Dim SP() As String


SP = Split(Combo, ",")


For i = LBound(SP) To UBound(SP) - 1
    If S1Copy.contains(CDbl(SP(i))) Then sc1 = sc1 + 1
    If S2Copy.contains(CDbl(SP(i))) Then sc2 = sc2 + 1
Next i


checkSets = sc1 = s1Size And sc2 = s2Size


End Function


Sub Pop(xSet As Object, Cnt As Integer)
Dim r As Integer
Dim obj As Variant: obj = Null


If Cnt > 0 Then
    r = Int((xSet.Count - 1) * Rnd)
    obj = xSet.Item(r)
    xSet.removeat r
    Cnt = Cnt - 1
    Results.Add obj
End If


End Sub


Sub fillList(xSet As Object, ARR() As Variant)


For i = LBound(ARR, 1) To UBound(ARR, 2)
    xSet.Add ARR(1, i)
Next i


End Sub
 
Upvote 0
Re: How to distribute known numbers into columns using VBA

Amazing, its working. Thank you very much for your time and your code.

One last thing, is possible I increment one element in my group, I mean, I tried changing from 15 to 16 this part of the code
Code: 
Dim GroupSize As Integer: GroupSize = 15
but it generates an error on
Code: 
Do Until Pick = 0    r = Int((Combos.Count - 1) * Rnd)
    
   ->>> Error in the line below when  a change the group to 16 elements 
            Sample.Add Combos.Item(r)


    Combos.removeat r
    Pick = Pick - 1
Loop
 
Last edited:
Upvote 0
Re: How to distribute known numbers into columns using VBA

It's a little screwy. I thought about scrapping it and starting over, but, it works.

So you would change
Code: 
Dim GroupSize As Integer: GroupSize = 16

But you need to adjust the set sizes as well. The code needs to know how many from each set to choose. That number will be 1 more than the amount that you actually want. So, if you want 10 from set 1,
Code: 
Dim cnt1 As Integer: cnt1 = 11
, and 6 from set 2,
Code: 
Dim cnt2 As Integer: cnt2 = 7
.

Then run it and it should work.
 
Upvote 0
Re: How to distribute known numbers into columns using VBA

Thank you very much. I made the changes you suggested and its working fine.
I will study your precious code, maybe in the future, if you allow me, I will be able to make some changes.

Thanks you again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
How to get random generator to pick from a list but delete the item it has picked
2
Replies
17
Views
533
Peter_SSs
Peter_SSs
M
  • Question
Can I combine randbetween, rept, and vlookup to get multiple answers?
Replies
4
Views
75
Marla89
M
D
  • Solved
Need help with random number generator
Replies
3
Views
351
Fluff
Fluff
S
  • Question
Vba - generate random alphanumeric strings based on user input
Replies
1
Views
161
DanteAmor
DanteAmor
N
  • Solved
Can I generate a random order but with two inputted numbers?
Replies
5
Views
356
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,589
Messages
6,120,416
Members
448,960
Latest member
AKSMITH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top