ReDim does not work if ONE number is used, only TWO numbers or more.

[S.H.A.D.O.]

Good evening,

The code below was originally posted by hiker95 in answer to another members question.
Here is the link to the other post if anyone is interested.

http://www.mrexcel.com/forum/excel-questions/674589-generate-combinations-5.html

Anyway, I have found this program CreateCombinationsV4 VERY useful.
There is one point however, the program depends on having AT LEAST TWO numbers in EACH of the a...e variables, if there isn't it throws out a Run-time error '13': Type mismatch error on the line...

    ReDim Nums(1 To UBound(A, 1) * UBound(B, 1) * UBound(C, 1) * UBound(D, 1) * UBound(E, 1) * UBound(F, 1), 1 To 6)

If I only want one number in one of the columns I can get round this by putting a 0 after the number so it doesn't throw out the error.
Is there a quick fix to allow there to be just ONE number also in one or more of the a...e please.
Other than this it works brilliantly!

Option Explicit
Option Base 1
Sub CreateCombinationsV4()
' hiker95, 12/16/2012
' http://www.mrexcel.com/forum/excel-questions/674589-generate-combinations.html
Dim o As Variant, a, b, c, d, e
Dim n As Long, i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
Dim cl As Long, hl As Long
Dim rng As Range
Application.ScreenUpdating = False
Columns("H:L").Clear
a = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
b = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
c = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
d = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
e = Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row)
ReDim o(1 To UBound(a, 1) * UBound(b, 1) * UBound(c, 1) * UBound(d, 1) * UBound(e, 1), 1 To 5)
n = 1
For i1 = 1 To UBound(a, 1)
  For i2 = 1 To UBound(b, 1)
    For i3 = 1 To UBound(c, 1)
      For i4 = 1 To UBound(d, 1)
        For i5 = 1 To UBound(e, 1)
          Range("H1:L1").Clear
          Cells(1, 8) = a(i1, 1)
          Cells(1, 9) = b(i2, 1)
          Cells(1, 10) = c(i3, 1)
          Cells(1, 11) = d(i4, 1)
          Cells(1, 12) = e(i5, 1)
          Set rng = Range("H1:L1")
          For cl = 8 To 12 Step 1
            hl = 0
            hl = Application.CountA(rng)
            If hl < 5 Then GoTo MyExit
            hl = 0
            hl = Application.CountIfs(rng, Cells(1, cl))
            If hl > 1 Then GoTo MyExit
          Next cl
          If a(i1, 1) > b(i2, 1) Or b(i2, 1) > c(i3, 1) Or c(i3, 1) > d(i4, 1) Or d(i4, 1) > e(i5, 1) Then GoTo MyExit
          o(n, 1) = a(i1, 1)
          o(n, 2) = b(i2, 1)
          o(n, 3) = c(i3, 1)
          o(n, 4) = d(i4, 1)
          o(n, 5) = e(i5, 1)
          n = n + 1
MyExit:
        Next i5
      Next i4
    Next i3
  Next i2
Next i1
Columns("H:L").Clear
Range("H1").Resize(UBound(o, 1), UBound(o, 2)) = o
Application.ScreenUpdating = True
End Sub

Thanks in advance and have a great weekend!

 

[hiker95]

S.H.A.D.O.,

Thanks for the Private Message.

Can we see what your raw data looks like?

 

[S.H.A.D.O.]

Hi hiker95,

Basically I have values in cells A1:E10.
In A there could be 1 number or 8 numbers for example, the same applies to the other columns.
The code runs fine except that at the moment there MUST be AT LEAST TWO numbers in each column otherwise I get the error message, that's all.
I would just like to be able to have only ONE number in a column if I so wished, other than that the code works perfectly and produces the correct results.
Thanks in advance.

 

[hiker95]

S.H.A.D.O.,

The original macro that I wrote, that you are trying to adjust, was for a completely different objective with strict rules based on the original OP's requirements.

You are not willing to display raw data, and, your have not displayed what your outcome/results should look like.


Here are some links that may suit your requirements:

Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc

Permutation & Combinations

CODE FOR PERMUTATIONS & COMBINATIONS - Microsoft Community

http://www.mrexcel.com/forum/excel-...ns-not-working-excel-2007-overflow-error.html

Excel: number combinations, permutation and combinations, number combinations

'
'
' Following is a macro based solution form Myrna Larson (Microsoft MVP) on permutation and combinations
' 1. It allows Combinations or Permutations.
' 2. The macro handles numbers, text strings, words (e.g. names of people) or symbols.
' 3. The combinations are written to a new sheet. (*****This needs to be changed. I want the result into new workbook*****)
' 4. Results are returned almost instantaneously.
' Setup:
' In sheet1:
' Cell A1, put "C" (Combinations) or "P" (Permutations).
' Cell A2, put the number of items in the subset - in my case it's 3.
' Cells A3 down, your list. - in my case (numbers from 1-5)


Powerset, Subset, and Combinations & Permutations
Power Set


Sub Permutations_pgc01()
' pgc01
Create list of all pair combinations


Sub Combos_Sum()
' Find all the combinations of six integer numbers, each in the range 1..49,
' that sum to the value of a desired total. A combination may not have two
' numbers that are the same. Results are written to columns A..F of the
' active worksheet.
'
' motilulla
' List out 6_49 lottery combinations only those with the sum of 100.
List out 6_49 lottery combinations only those with the sum of 100.

 

[S.H.A.D.O.]

Hi hiker95,

The original macro that I wrote, that you are trying to adjust, was for a completely different objective with strict rules based on the original OP's requirements.

I am fully aware and appreciate what the OP wanted and funny enough that is exactly what I am finding useful, it is exactly what I am after except you have to have a minimum of two numbers in any column. I would like to have a minimum of ONE number in a column if needed.
I had trouble with HTML Maker but I think it is sorted now so here is the raw data, this is the first time I have used HTML Maker so please bear with me:-

Excel 2007
	A	B	C	D	E
1	1	11	12	15	31
2	2	12	14	22	32
3	3		15
4	4
5
6
7
8
9
10
Sheet1

...and here are the combinations that they produce which are correct:-

Excel 2007
	H	I	J	K	L
1	1	11	12	15	31
2	1	11	12	15	32
3	1	11	12	22	31
4	1	11	12	22	32
5	1	11	14	15	31
6	1	11	14	15	32
7	1	11	14	22	31
8	1	11	14	22	32
9	1	11	15	22	31
10	1	11	15	22	32
11	1	12	14	15	31
12	1	12	14	15	32
13	1	12	14	22	31
14	1	12	14	22	32
15	1	12	15	22	31
16	1	12	15	22	32
17	2	11	12	15	31
18	2	11	12	15	32
19	2	11	12	22	31
20	2	11	12	22	32
21	2	11	14	15	31
22	2	11	14	15	32
23	2	11	14	22	31
24	2	11	14	22	32
25	2	11	15	22	31
26	2	11	15	22	32
27	2	12	14	15	31
28	2	12	14	15	32
29	2	12	14	22	31
30	2	12	14	22	32
31	2	12	15	22	31
32	2	12	15	22	32
33	3	11	12	15	31
34	3	11	12	15	32
35	3	11	12	22	31
36	3	11	12	22	32
37	3	11	14	15	31
38	3	11	14	15	32
39	3	11	14	22	31
40	3	11	14	22	32
41	3	11	15	22	31
42	3	11	15	22	32
43	3	12	14	15	31
44	3	12	14	15	32
45	3	12	14	22	31
46	3	12	14	22	32
47	3	12	15	22	31
48	3	12	15	22	32
49	4	11	12	15	31
50	4	11	12	15	32
51	4	11	12	22	31
52	4	11	12	22	32
53	4	11	14	15	31
54	4	11	14	15	32
55	4	11	14	22	31
56	4	11	14	22	32
57	4	11	15	22	31
58	4	11	15	22	32
59	4	12	14	15	31
60	4	12	14	15	32
61	4	12	14	22	31
62	4	12	14	22	32
63	4	12	15	22	31
64	4	12	15	22	32
Sheet1

You will see that I have the same number in columns C & D and the macro has only counted them in a combination once, which is perfect.
Thanks in advance.

 

[S.H.A.D.O.]

Just as a follow up.

I have spent a few hours trying to get this to work but to no avail.
I have tried ReDim Preserve, but on investigations it seems that this is not what I need.
I have tried ReDim IsNumeric but had no joy with that either.
I think it is because you can't use ReDim if there is only one value, but I might be wrong?
I did try putting a blank in the cells that I didn't use but that made the program run a LONG time.
Any help will be greatly appreciated.

Thanks in advance.

 

[S.H.A.D.O.]

Well I have been through the list that hiker95 provided and haven't found an answer to my initial question.
I have been researching on the Internet for the last three and a bit hours and it seems that the ReDim cannot be used for a single value.
I saw something that said about maybe transposing the data for rows to columns and columns to rows, but unfortunately I don't have any idea how to go about this.
I didn't realise that what seems to be a simple change is so complicated.
Any help will be appreciated.
Thanks in advance.

 

[John_w]

There is one point however, the program depends on having AT LEAST TWO numbers in EACH of the a...e variables, if there isn't it throws out a Run-time error '13': Type mismatch error on the line...

    ReDim Nums(1 To UBound(A, 1) * UBound(B, 1) * UBound(C, 1) * UBound(D, 1) * UBound(E, 1) * UBound(F, 1), 1 To 6)

Check if a, b, c etc. are arrays, like this:

    Dim an As Integer, bn As Integer, cn As Integer, dn As Integer, en As Integer
    If IsArray(a) Then an = UBound(a, 1) Else an = 1
    If IsArray(b) Then bn = UBound(b, 1) Else bn = 1
    If IsArray(c) Then cn = UBound(c, 1) Else cn = 1
    If IsArray(d) Then dn = UBound(d, 1) Else dn = 1
    If IsArray(e) Then en = UBound(e, 1) Else en = 1
    ReDim o(1 To an * bn * cn * dn * en, 1 To 5)

 

[S.H.A.D.O.]

Check if a, b, c etc. are arrays, like this:

    Dim an As Integer, bn As Integer, cn As Integer, dn As Integer, en As Integer
    If IsArray(a) Then an = UBound(a, 1) Else an = 1
    If IsArray(b) Then bn = UBound(b, 1) Else bn = 1
    If IsArray(c) Then cn = UBound(c, 1) Else cn = 1
    If IsArray(d) Then dn = UBound(d, 1) Else dn = 1
    If IsArray(e) Then en = UBound(e, 1) Else en = 1
    ReDim o(1 To an * bn * cn * dn * en, 1 To 5)

Thanks for the reply John_w, but I couldn't get it to work.
Am I right in saying that I should replace:

a = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
b = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
c = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
d = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
e = Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row)
ReDim o(1 To UBound(a, 1) * UBound(b, 1) * UBound(c, 1) * UBound(d, 1) * UBound(e, 1), 1 To 5)

With...

 Dim an As Integer, bn As Integer, cn As Integer, dn As Integer, en As Integer
    If IsArray(a) Then an = UBound(a, 1) Else an = 1
    If IsArray(b) Then bn = UBound(b, 1) Else bn = 1
    If IsArray(c) Then cn = UBound(c, 1) Else cn = 1
    If IsArray(d) Then dn = UBound(d, 1) Else dn = 1
    If IsArray(e) Then en = UBound(e, 1) Else en = 1
    ReDim o(1 To an * bn * cn * dn * en, 1 To 5)

I tried several ways of doing it but couldn't get it to work, sorry.
Thanks in advance.

 

[John_w]

No, replace the ReDim o line with all my lines. With your change a, b, c etc. are undefined. You still need all the xx = Range(....) statements. This gives:

a = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
b = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
c = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
d = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
e = Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row)
Dim an As Integer, bn As Integer, cn As Integer, dn As Integer, en As Integer
    If IsArray(a) Then an = UBound(a, 1) Else an = 1
    If IsArray(b) Then bn = UBound(b, 1) Else bn = 1
    If IsArray(c) Then cn = UBound(c, 1) Else cn = 1
    If IsArray(d) Then dn = UBound(d, 1) Else dn = 1
    If IsArray(e) Then en = UBound(e, 1) Else en = 1
    ReDim o(1 To an * bn * cn * dn * en, 1 To 5)