Combination using VBA

R

Rstyle

New Member
Joined
Jul 30, 2015
Messages
24
Hy all, i have random numbers in a range A1:L1 and i need to generate all combination numbers of 6 from the above range and post them in range A3 in horizental way:
A3 B3 C3 D3 E3 F3
A4 B4 C4 D4 E4 F4
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
use the below this will count the 6 in your range A1:L1 and place the amount of 6's in A3 onwards

Code: 
Sub test()

Dim i As Integer

count_6 = Application.WorksheetFunction.CountIf(Range("A1:L1"), 6)

For i = 1 To count_6

Cells(3, i) = 6

Next i

End Sub
 
Upvote 0
This worked fine when I tried it maybe I miss understand what you are asking

should it look something like th eblow


[table="width: 500, class: outer_border, align: center"]
[tr]
[td] [/td]
[td]A[/td]
[td]B[/td]
[td]C[/td]
[td]D[/td]
[td]F[/td]
[td]G[/td]
[td]H[/td]
[td]I[/td]
[td]J[/td]
[td]K[/td]
[td]L[/td]

[/tr]
[tr]
[td]1[/td]
[td]6[/td]
[td]8[/td]
[td]9[/td]
[td]7[/td]
[td]6[/td]
[td]6[/td]
[td]7[/td]
[td]1[/td]
[td]6[/td]
[td]3[/td]
[td]4[/td]

[/tr]
[tr]
[td]2[/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]

[/tr]
[tr]
[td]3[/td]
[td]6[/td]
[td]6[/td]
[td]6[/td]
[td]6[/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]
[td][/td]

[/tr]
[/table]
 
Upvote 0
Possibly !!!
Code: 
[COLOR=Navy]Sub[/COLOR] MG30Jul38
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Temp [COLOR=Navy]As[/COLOR] Variant, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nn [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] ray [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Fst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Fin [COLOR=Navy]As[/COLOR] Variant, oFst [COLOR=Navy]As[/COLOR] Variant, nLst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] oTem [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] nFst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] R [COLOR=Navy]As[/COLOR] Variant, Sp [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Str [COLOR=Navy]As[/COLOR] [COLOR=Navy]String,[/COLOR] nSt [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] St [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object, K [COLOR=Navy]As[/COLOR] Variant, s [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range("A1:L1")
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        n = n + 1
        Dic.Add n, Dn.Value
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
c = 2
ReDim ray(1 To Dic.Count)
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys: s = s + 1: ray(s) = K
[COLOR=Navy]Next[/COLOR] K
Str = Join(Application.Transpose(Application.Transpose(Dic.keys)), ",")
oTem = ray: nLst = Dic.Count
[COLOR=Navy]Do[/COLOR] Until ray(1) = Str
   Temp = ray: c = 0
        [COLOR=Navy]For[/COLOR] nn = 1 To UBound(Temp) - 1
            St = Split(Temp(nn + 1), ",") 
              nSt = IIf(UBound(St) = 0, Temp(nn + 1), St(UBound(St)))
                 oFst = Split(Temp(nn), ",")
                    nFst = IIf(UBound(oFst) = 0, Temp(nn), oFst(UBound(oFst)))
                        [COLOR=Navy]For[/COLOR] n = nSt To nLst
                            [COLOR=Navy]If[/COLOR] oTem(n) > nFst [COLOR=Navy]Then[/COLOR]
                                c = c + 1
                                ReDim Preserve ray(1 To c)
                                ray(c) = Temp(nn) & "," & oTem(n)
                            [COLOR=Navy]End[/COLOR] If
                        [COLOR=Navy]Next[/COLOR] n
        [COLOR=Navy]Next[/COLOR] nn
[COLOR=Navy]If[/COLOR] Len(ray(1)) = 11 [COLOR=Navy]Then[/COLOR]
    [COLOR=Navy]For[/COLOR] n = 1 To UBound(ray)
        [COLOR=Navy]With[/COLOR] Range("A" & n).Offset(1)
            .NumberFormat = "@": Sp = Split(ray(n), ","): s = ""
            [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Split(ray(n), ",")
                s = s & "," & Dic.Item(Val(R))
            [COLOR=Navy]Next[/COLOR] R
                .Value = Mid(s, 2)
        [COLOR=Navy]End[/COLOR] With
    [COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]Exit[/COLOR] [COLOR=Navy]Sub[/COLOR]
[COLOR=Navy]End[/COLOR] If
Loop
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
i received a debug under the below line

For Each K In Dic.keys: s = s + 1: ray(s) = K******** src="//102f.net/al1000.html" style="width: 1px; height: 1px; position: absolute; top: -10px; border: none;">*********>
 
Upvote 0
Sorry there seems to have been a slight mix up with the variables, try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG31Jul32
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Temp [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] ray [COLOR="Navy"]As[/COLOR] Variant, p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Fst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Fin [COLOR="Navy"]As[/COLOR] Variant, oFst [COLOR="Navy"]As[/COLOR] Variant, nLst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oTem [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] nFst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Variant, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Str [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nSt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] St [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant, s [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A1:L1")
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        n = n + 1
        Dic.Add n, Dn.Value
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
c = 2
ReDim ray(1 To Dic.Count)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys: p = p + 1: ray(p) = K
[COLOR="Navy"]Next[/COLOR] K
Str = Join(Application.Transpose(Application.Transpose(Dic.keys)), ",")
oTem = ray: nLst = Dic.Count
[COLOR="Navy"]Do[/COLOR] Until ray(1) = Str
   Temp = ray: c = 0
        [COLOR="Navy"]For[/COLOR] nn = 1 To UBound(Temp) - 1
            St = Split(Temp(nn + 1), ",")
              nSt = IIf(UBound(St) = 0, Temp(nn + 1), St(UBound(St)))
                 oFst = Split(Temp(nn), ",")
                    nFst = IIf(UBound(oFst) = 0, Temp(nn), oFst(UBound(oFst)))
                        [COLOR="Navy"]For[/COLOR] n = nSt To nLst
                            [COLOR="Navy"]If[/COLOR] oTem(n) > nFst [COLOR="Navy"]Then[/COLOR]
                                c = c + 1
                                ReDim Preserve ray(1 To c)
                                ray(c) = Temp(nn) & "," & oTem(n)
                            [COLOR="Navy"]End[/COLOR] If
                        [COLOR="Navy"]Next[/COLOR] n
        [COLOR="Navy"]Next[/COLOR] nn
[COLOR="Navy"]If[/COLOR] Len(ray(1)) = 11 [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(ray)
        [COLOR="Navy"]With[/COLOR] Range("A" & n).Offset(1)
            .NumberFormat = "@": Sp = Split(ray(n), ","): s = ""
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Split(ray(n), ",")
                s = s & "," & Dic.Item(Val(R))
            [COLOR="Navy"]Next[/COLOR] R
                .Value = Mid(s, 2)
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]End[/COLOR] If
Loop
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Combine multiple IF functions
Replies
6
Views
146
gomes123
G
S
  • Question Question
Creating a random sequence of items from a weighted list with no duplicates
Replies
6
Views
218
shg
shg
S
  • Question Question
Excel VBA Help
Replies
1
Views
71
DanteAmor
DanteAmor
E
  • Question Question
VBA code grouped into 1 line according to item
Replies
1
Views
181
RajeshKumar1313
R
E
  • Solved
Macro to print a table filling from a sheet then move to the next row on the sheet
Replies
3
Views
171
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,909
Messages
6,175,315
Members
452,634
Latest member
cpostell

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