# Combination, Repeats (AAB,BBC) allowed, Repeats (AAC,ACA,CAA) only considered as One

#### yauchildchew

##### New Member
Say, generating possible combinations of 4 elements with [ABC].
1) Repetition of elements are allowed: AABB, BACA, BBBA...
2) Repetition of combinations with similar elements are only considered as one combination: ABBC, BABC, BCAB, CABB....

How to code this?

From this forum, I also find out an example of generating combinations which Repetitions as of 1) and 2) are allowed.

Code:
``````Sub allup()
Dim a, n As Integer, c(), k As Long
Dim u1 As Integer, u2 As Integer, u3 As Integer
Dim u4 As Integer, u5 As Integer, u6 As Integer
Dim u7 As Integer, u8 As Integer, u9 As Integer
a = Array("C", "M", "U")
n = UBound(a) + 1
ReDim c(1 To Rows.Count, 1 To 9)
For u1 = 1 To n
For u2 = 1 To n
For u3 = 1 To n
For u4 = 1 To n
For u5 = 1 To n
For u6 = 1 To n
For u7 = 1 To n
For u8 = 1 To n
For u9 = 1 To n
k = k + 1
c(k, 9) = a(u9 - 1)
c(k, 8) = a(u8 - 1)
c(k, 7) = a(u7 - 1)
c(k, 6) = a(u6 - 1)
c(k, 5) = a(u5 - 1)
c(k, 4) = a(u4 - 1)
c(k, 3) = a(u3 - 1)
c(k, 2) = a(u2 - 1)
c(k, 1) = a(u1 - 1)
Next u9, u8, u7, u6, u5, u4, u3, u2, u1
Cells(1).Resize(k, 9) = c
End Sub``````
While looking for solution for the mentioned question, I am trying to generate combinations like the one above in the other way, as shown in codes below. It is written based on the idea of codes above. However, I cant achieve what I want yet.

Code:
``````Private Sub btngeneratecomb_Click()
Dim i, n As Integer, c(), k As Long
Dim u() As Integer

ReDim u(i = 1 To housenum)

n = fmdemand.lstselected.ListCount

ReDim c(1 To Rows.Count, 1 To housenum)

For i = 1 To housenum
For u(i) = 1 To n

Dim j As Integer
For j = 1 To housenum

Dim h As Integer
For h = 1 To fmdemand.lstselected.ListCount

k = k + 1
c(k, j) = fmdemand.lstselected.List(h - 1)

Next h
Next j

Next u(i)
Next i

Sheets("Sheet1").Select
Range("A1").Select
ActiveCell.Resize(k, i) = c
End Sub``````
The 1st picture is the current output from my code and the 2nd is the output from the 1st code. I would like to generate something like the 2nd pic by considering repetition of combinations with similar elements as one combination.

Thanks.

### Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

#### pgc01

##### MrExcel MVP
Hi yauchildchew
Welcome to the board

If you don't mind using a more general solution I posted some time ago a solution for the 4 usual combinatorics problems:

- Comb=True, Repet=False - Combinations without repetition
- Comb=True, Repet=True - Combinations with repetition
- Comb=False, Repet=False - Permutations without repetition
- Comb=False, Repet=True - Permutations with repetition

Your example: Combinations with repetition of 3 elements taken 4 at a time.

- B1=4 , 4 elements taken at a time
- B2=True - Combinations
- B3=True - with repetition
- B5:B8, The set of elements is in B5, down

Just set the values in column B and run the code.

Code:
``````Option Explicit

' PGC Set 2007
' Calculates and writes the Combinations / Permutations with/without repetition
' vElements - Array with the set elements (1 to n)
' p - number of elements in 1 combination/permutation
' bComb - True: Combinations, False: Permutations
' bRepet - True: with repetition, False: without repetition
' vResult - Array to hold 1 permutation/combination (1 to p)
' lRow - row number. the next combination/permutation is written in lRow+1
' vResultAll - Array to hold all the permutations/combinations (1 to Total, 1 to p)
' iElement - order of the element to process in case of combination
' iIndex - position of the next element in the combination/permutation
' Sub CombPerm() deals with the input / output
' Sub CombPermNP() generates the combinations / permutations
Sub CombPerm()
Dim rRng As Range, p As Integer
Dim vElements As Variant, vResult As Variant, vResultAll As Variant, lTotal As Long
Dim lRow As Long, bComb As Boolean, bRepet As Boolean

' Get the inputs and clear the result range (you may adjust for other locations)
Set rRng = Range("B5", Range("B5").End(xlDown)) ' The set of numbers
p = Range("B1").Value ' How many are picked
bComb = Range("B2")
bRepet = Range("B3")

Columns("D").Resize(, p + 1).Clear

' Error
If (Not bRepet) And (rRng.Count < p) Then
MsgBox "With no repetition the number of elements of the set must be bigger or equal to p"
Exit Sub
End If

' Set up the arrays for the set elements and the result
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
With Application.WorksheetFunction
If bComb = True Then
lTotal = .Combin(rRng.Count + IIf(bRepet, p - 1, 0), p)
Else
If bRepet = False Then lTotal = .Permut(rRng.Count, p) Else lTotal = rRng.Count ^ p
End If
End With
ReDim vResult(1 To p)
ReDim vResultAll(1 To lTotal, 1 To p)

' Calculate the Combinations / Permutations
Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, 1, 1)
Range("D1").Resize(lTotal, p).Value = vResultAll  'you may adjust for other location
End Sub

Sub CombPermNP(ByVal vElements As Variant, ByVal p As Integer, ByVal bComb As Boolean, ByVal bRepet As Boolean, _
ByVal vResult As Variant, ByRef lRow As Long, ByRef vResultAll As Variant, ByVal iElement As Integer, ByVal iIndex As Integer)
Dim i As Integer, j As Integer, bSkip As Boolean

For i = IIf(bComb, iElement, 1) To UBound(vElements)
bSkip = False
' in case of permutation without repetition makes sure the element is not yet used
If (Not bComb) And Not bRepet Then
For j = 1 To p
If vElements(i) = vResult(j) And Not IsEmpty(vResult(j)) Then
bSkip = True
Exit For
End If
Next
End If

If Not bSkip Then
vResult(iIndex) = vElements(i)
If iIndex = p Then
lRow = lRow + 1
For j = 1 To p
vResultAll(lRow, j) = vResult(j)
Next j
Else
Call CombPermNP(vElements, p, bComb, bRepet, vResult, lRow, vResultAll, i + IIf(bComb And bRepet, 0, 1), iIndex + 1)
End If
End If
Next i
End Sub``````

Remark: As I said this is a solution for the 4 usual cases of combinatorics problems. You may prefer a simpler solution for your specific case of Combinations with Repetition.

#### yauchildchew

##### New Member
Thanks! You have showed me 99% of what I wanted!!
With this, i believe I can work out what I want! Saving me a lot of time!

Well, as max row is 1048576, how to code so that when more rows are required, tnew worksheet(s) with identical name to the 1st result worksheet will be generated so that generation continues in there?

Thanks!

#### pgc01

##### MrExcel MVP
Hi

I must say that it makes no sense to me to want to write millions of combinations in worksheets .

If that's what you want, however, you can change the code.

The code works with an array and then writes the array to the worksheet.

This means that you only need to change the last statement before the end, that writes the array vResultAll to the worksheet:

Code:
``Range("D1").Resize(lTotal, p).Value = vResultAll  'you may adjust for other location``

You may notice that I had already written as a comment that you might want to adjust it. For example, divide the array in chunks of 1 million combinations and write them in the columns to the right.

This is no longer a problem related to generating combinations, it's just writing a big array to the workbook.

As I said, I don't understand why you would want to write millions of combinations to the workbook, but since we are at it, it is worth mentioning that you may have so many combinations that you run out of memory in your computer. So, if you would want to write like billions of combinations to the workbook you'd have to change the code (and be prepared to wait a long time fot the execution of the code).

#### yauchildchew

##### New Member

Thanks again for the help.

You are right at what you said about the point of generating so many combination. In fact, I am doing some kind of an optimization of a simulation model. I know it makes sense that the simulation will run for million times to find out the desired number(s) but it doesnt make much sense to write out all the generated outputs. However, at this moment, due to my limited programming ability, I have to do it step by step, in the hard way.

By the way, it really takes so much time! Haha!
With multi-core and multi-thread CPU nowadays, I wonder if Excel is making use of such hardware ability or it is dependent on how we write the code to utilize the multi-threading processing ability?

With codes below, you can see that I am trying to produce an table output with 5 columns (i) and "totalcombination" number of rows. Say, the output worksheet is B and the reference worksheet to be A. For each row, I fill in each column (cell) by refering to A, copy from A and paste it to B, cell by cell.

I wonder if the processing time will be shortened greatly if I write a code to copy by RANGE, rather than by CELL? Can you show me a simple code to copy by RANGE and paste as RANGE?

Code:
``````Dim j As Integer
Dim i As Integer
Dim x As Integer

ReDim combineddemand(j = 1 To totalcombination, i = 1 To 5)
ReDim addcombineddemand(j = 1 To totalcombination, i = 1 To 5)

ReDim combineddemandname(j = 1 To totalcombination)
ReDim addcombineddemandname(x = 1 To housenum)

Dim totalcombinationstr As String
totalcombinationstr = Str(totalcombination)
MsgBox (totalcombinationstr + " will be generated.")

For j = 1 To totalcombination
For i = 1 To 5
combineddemand(j, i) = 0

For x = 1 To housenum

Sheets("selected demand").Select

Select Case Sheets("combination").Cells(4 + j, 2 + x).Value
Case Sheets("selected demand").Cells(1, 2).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 2).Value
Case Sheets("selected demand").Cells(1, 3).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 3).Value
Case Sheets("selected demand").Cells(1, 4).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 4).Value
Case Sheets("selected demand").Cells(1, 5).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 5).Value
Case Sheets("selected demand").Cells(1, 6).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 6).Value
Case Sheets("selected demand").Cells(1, 7).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 7).Value
Case Sheets("selected demand").Cells(1, 8).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 8).Value
Case Sheets("selected demand").Cells(1, 9).Value
addcombineddemand(j, i) = Sheets("selected demand").Cells(2 + i, 9).Value
Case Else
End Select

combineddemand(j, i) = combineddemand(j, i) + addcombineddemand(j, i)

Sheets("dmdcombine").Select
Cells(2 + j, 1).Value = combineddemandname(j)

Next x

Sheets("dmdcombine").Select
Cells(2 + j, 1 + i).Value = combineddemand(j, i)

Next i
Next j``````
Thanks for time and attention!

Again, the embedded code is not giving the desired result yet, but I believe that it shows what I try to achieve.

#### pgc01

##### MrExcel MVP
You are right at what you said about the point of generating so many combination. In fact, I am doing some kind of an optimization of a simulation model. I know it makes sense that the simulation will run for million times to find out the desired number(s) but it doesnt make much sense to write out all the generated outputs. However, at this moment, due to my limited programming ability, I have to do it step by step, in the hard way.

Ok. I'm posting an example that splits the array and writes in groups of columns to the right.

A clean and flexible way to write the array is to take care of it in another sub. This let's you adjust it without changing the main code.

This is an example.

- Comment or delete the statement:

Code:
``Columns("D").Resize(, p + 1).Clear``

- and replace the statement

Code:
``'Range("D1").Resize(lTotal, p).Value = vResultAll  'you may adjust for other location``

with

Code:
``WriteArray vResultAll, Range("D1") ' Writes the array in chunks``

Now WriteArray will be some code that writes the array to the workbook. It's independent from the rest of the code and you can do it the way you want.

In this example this WriteArray Sub will write the array in chunks of 1 million rows. Each chunk is written in the columns to the right with a 2 columns interval.

Code:
``````Sub WriteArray(vResultAll As Variant, rOut As Range)
Dim vArrTemp As Variant, lMaxArrTemp As Long
Dim p As Long, lMaxChunks As Long
Dim j As Long, k As Long, i As Long

Const lMaxRows As Long = 1000000

Application.ScreenUpdating = False
p = UBound(vResultAll, 2)
lMaxChunks = (UBound(vResultAll) - 1) \ lMaxRows
rOut.Resize(lMaxRows, (lMaxChunks + 1) * (p + 2)).Clear

' write chunks of lMaxRows
For j = 0 To lMaxChunks
lMaxArrTemp = IIf((j + 1) * lMaxRows + 1 < UBound(vResultAll), lMaxRows, UBound(vResultAll) Mod lMaxRows)
ReDim vArrTemp(1 To lMaxArrTemp, 1 To p)
For k = 1 To lMaxArrTemp
For i = 1 To p
vArrTemp(k, i) = vResultAll(j * lMaxRows + k, i)
Next i
Next k
rOut.Offset(0, j * (p + 2)).Resize(lMaxArrTemp, p).Value = vArrTemp
Next j
Application.ScreenUpdating = True
End Sub``````

In this test I generated combinations with repetition of 30 elements taken 6 at a time. The total number of combinations is 1,623,160. The code wrote the first million in columns D:I and the rest in L:Q

Inputs:

B1 - 6
B2 - True
B3 - True
B5:B34 - numbers 1-30

I wonder if the processing time will be shortened greatly if I write a code to copy by RANGE, rather than by CELL? Can you show me a simple code to copy by RANGE and paste as RANGE?

Yes, it can get very slow if you write cell by cell.

It's much quicker if you either copy a whole range, like

Code:
``Range("J1:J10000").Value = Range("A1:A10000").Value``

or if you write an array in one statement, ex:

Code:
``````Dim lArr(1 To 10000, 1 To 3)

' some code that puts values in the array

Range("A1:C10000").Value = lArrr``````

Remark: Sorry, I did not understand the rest of your post.

Hope this helps.

#### Weaver

##### Well-known Member

****, I got to this party late!

I think this answers the original question, but apparently things have moved on since then. Posted anyway, cos I think it's neat

Code:
``````Sub generateCombinations()
Dim maxLen As Integer, possVal As String, maxRep As Integer, mainList As Variant
Set mainList = CreateObject("Scripting.Dictionary")
maxLen = 4
possVal = "ABC"
maxRep = 4
Application.ScreenUpdating = False
genCom "", maxLen, possVal, maxRep, mainList
With mainList
Range("A1").Resize(.Count, 1) = Application.Transpose(Array(.items))
End With
End Sub

Sub genCom(c, m, p, r, x)
If Len(c) = m Then
op c, p, x
Else
For i = 1 To Len(p)
k = Mid(p, i, 1)
If Len(c) - Len(Replace(c, k, "")) < r Then
genCom c & k, m, p, r, x
End If
Next i
End If
End Sub

Sub op(o, p, x)
c = cs(o, p)
If Not x.exists(c) Then
End If
End Sub

Function cs(o, p)
For i = 1 To Len(o)
cs = cs + 10 ^ InStr(p, Mid(o, i, 1))
Next i
End Function``````

#### yauchildchew

##### New Member
Thanks PGC01! You have cleared most of my doubts!

And thanks Weaver and it's never too late. I can learn from your codes too!

#### mgirvin

##### Well-known Member
pgc01,

The code from the second post is very useful to me for the basic statistics class that I teach. I create sets like this by hand. This code will definitely speed things up.

Thanks!

#### pgc01

##### MrExcel MVP
That's nice, Mike. I'm glad it helps.

Cheers!

Replies
2
Views
152
Replies
0
Views
74
Replies
8
Views
401
Replies
3
Views
57
Replies
4
Views
125

1,136,303
Messages
5,674,970
Members
419,537
Latest member
ucatchy

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

### Which adblocker are you using?

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

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