#### S.H.A.D.O.

##### Well-known Member

- Joined
- Sep 6, 2005

- Messages
- 1,915

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...

Code:

` 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!

Code:

```
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!