vba code for Combinations

**hallwod** · 03-18-2016, 01:31 PM

I should be able to get my head round this but have a complete mental block. Im trying to write an algorithim and then a vba user defined function to solve the following problem:

I have N (max 32) display panels and each panel can have any one of R (say 4) layout configurations. I want to write a code which will output an array of N columns with each row populated with the Layout number (I've used letters for clarity only):

For example a 3 panel situation would output

AAA
AAB
AAC
AAD
ABB
ABC
ABD
ACC
ACD
ADD
BBB
BBC
BBD
BCC
BCD
BDD
CCC
CCD
CDD
DDD

I know the maths to work out the number of non repetetive combinations - its the logic of generating the aray table which has defeated me.

Any help would be gratefully received.

Thanks in anticipation

**shg** · 03-18-2016, 01:50 PM

Welcome to the board. For a formula-based solution,

Row\Col	A	B	C	D
2	A	A	A	A2: =CHAR(65 + MOD(INT(4 * (ROWS($C$2:Me) - 1) / 4 ^ COLUMNS($C$2:Me)), 4))
3	A	A	B
4	A	A	C
5	A	A	D
6	A	B	A
7	A	B	B
8	A	B	C
9	A	B	D
10	A	C	A
11	A	C	B
12	A	C	C
13	A	C	D
14	A	D	A
15	A	D	B

**hallwod** · 03-18-2016, 02:10 PM

Thanks Guru for the very quick response. I seem to get a Name error when entering this formula in A2??

I suspect the formula based approach may work well for small values of N but I do need a vba solution in order to develop my project further.

Thanks again

**shg** · 03-18-2016, 02:29 PM

Sorry, it's a standard name for me.

In A2,

=CHAR(65 + MOD(INT(4 * (ROWS($C$2:A2) - 1) / 4 ^ COLUMNS($C$2:A2)), 4))

**hallwod** · 03-19-2016, 05:37 PM

shg, Many thanks for the revision and vba code. I'll work on this but it's certainly given me the kick start I needed. Regards

**shg** · 03-18-2016, 02:33 PM

Via VBA,

Row\Col	A	B	C	D	E
1	States	ABCDE		ABCD
2	Start	AAA	B2: Input	AAAA	D2: Input
3		AAB	B3: =DecToBij(BijToDec(B2, B$1) + 1, B$1)	AAAB	D3: =DecToBij(BijToDec(D2, D$1) + 1, D$1)
4		AAC		AAAC
5		AAD		AAAD
6		AAE		AABA
7		ABA		AABB
8		ABB		AABC
9		ABC		AABD
10		ABD		AACA
11		ABE		AACB
12		ACA		AACC
13		ACB		AACD
14		ACC		AADA
15		ACD		AADB
16		ACE		AADC
17		ADA		AADD

Function DecToBij(iNum As Long, sSym As String) As String
  ' shg 2014
  ' VBA or UDF
  
  ' Base sSym
  '   1  "1" (Tally)
  '   2  "12"
  '  10  "123456789A"
  '  26  "ABCDEFGHIJKLMNOPQRSTUVWXYZ" (Excel)
  
  ' Returns the bijective numeral for iNum using the digits in sSym
  
  ' https://en.wikipedia.org/wiki/Bijective_numeration
  ' https://en.wikipedia.org/wiki/Shortlex_order
  '

  If iNum > 0 Then DecToBij = DecToBij((iNum - 1) \ Len(sSym), sSym) & _
     Mid(sSym, ((iNum - 1) Mod Len(sSym)) + 1, 1)
End Function

Function BijToDec(sBij As String, sSym As String) As Long
  ' shg 2014
  ' VBA or UDF
  ' Returns the decimal value for the bijective numeral in sBij
  ' https://en.wikipedia.org/wiki/Bijective_numeration
  ' https://en.wikipedia.org/wiki/Shortlex_order

  If Len(sBij) Then BijToDec = InStr(sSym, Right(sBij, 1)) _
     + Len(sSym) * BijToDec(Left(sBij, Len(sBij) - 1), sSym)
End Function

**mehmetcik** · 03-18-2016, 03:20 PM


Option Base 1
Sub macro1()
Optimise (False)

MyDir = MyPath = ActiveWorkbook.Path

FileCount = 1

Columns("A:AF").Clear
Dim MyArray(32)
Dim MyArray2(32)

For Count = 1 To 32

MyArray(Count) = 0
MyArray2(Count) = 0

Next


Row = 0

Loop1:
Column = 32
Row = Row + 1
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, 32)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 0: MyArray2(Column) = 0: Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

**hallwod** · 03-20-2016, 07:36 AM

mehmetcik, I was sure I had replied to your post yesterday but clearly not! Thanks very much indeed for this code. I have run it but I get a Run-Time 1004 error Application defined or Object defined error. So I changed the 32 columns to 4 and ran it again. This time the output ran to 625 lines and a sample of the first few is as below:

On running Debug there appears to be a problem at the line "Range(Cells(Row, 1), Cells(Row, 32)).Value = MyArray2". Should there be a dimension variant for MyArray2?. Also in the line above you have "Display = Display+1 but I cannot see where that variable appears elsewhere in the routine.

I would be very grateful if you could please have a look again and point me in the right direction. Your help is much appreciated

0 0 0 0
0 0 0 A
0 0 0 B
0 0 0 C
0 0 0 D
0 0 A 0
0 0 A A
0 0 A B
0 0 A C
0 0 A D
0 0 B 0
0 0 B A
0 0 B B
0 0 B C
0 0 B D
0 0 C 0
0 0 C A
0 0 C B
0 0 C C
0 0 C D
0 0 D 0
0 0 D A
0 0 D B
0 0 D C
0 0 D D

**mehmetcik** · 03-20-2016, 08:04 AM

oops, it crashes at row 1048576,I didn't think you would need that many rows. I can set it to move across 40 columns at 1048476 and continue there. BRB

0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 B C B 0 B C C 0 0

revised code:


Option Base 1
Sub macro1()
Optimise (False)

MyDir = MyPath = ActiveWorkbook.Path

FileCount = 1

Columns("A:AF").Clear
Dim MyArray(32)
Dim MyArray2(32)

Offset = 0
For Count = 1 To 32

MyArray(Count) = 0
MyArray2(Count) = 0

Next


Row = 0

Loop1:
Column = 32
Row = Row + 1
If Row > Rows.Count - 99 Then Row = 0: Offset = Offset + 40
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, 32 + Offset)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 0: MyArray2(Column) = 0: Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

**mehmetcik** · 03-20-2016, 08:28 AM

It crashed again, must be running out of memory,

I have modified MyArray2 to save memory and trying again.

I only have a small laptop.

It might work better on an office PC


Option Base 1
Sub macro1()
Optimise (False)

MyDir = MyPath = ActiveWorkbook.Path

FileCount = 1

Columns("A:AF").Clear
Dim MyArray(32)
Dim MyArray2(32)

Offset = 0
For Count = 1 To 32

MyArray(Count) = 0
'MyArray2(Count) = 0 took this out to save memory

Next


Row = 0

Loop1:
Column = 32
Row = Row + 1
If Row > Rows.Count - 99 Then Row = 0: Offset = Offset + 34
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, 32 + Offset)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 0: MyArray2(Column) = 0: Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

**hallwod** · 03-20-2016, 08:38 AM

Thanks for your continuing work. I hope we are not at cross purposes here. I was anticipating the output for a 4 col ABCD arrangement to be:
AAAA
AAAB
AAAC
AAAD
AABB
AABC
AABD
AACC
AACD
AADD
ABBB
etc.
This is for all the combinations without repetition. The maths to work out what the number of non repeating combinations is (N+R-1)!/R!(N-1)! So for R=32 and N=4 there are only 6,545 combinations and for R=4 and N=4 only 35

R=32 is what I will eventually need and I was going to adapt your code into a user defined function into which I could pass variable values for R & N. Does the above make it any easier?? Cheers DJH

**mehmetcik** · 03-20-2016, 08:41 AM

It crashed at row 1048477 hmmmm.

I think a separate pages might do the trick.


Option Base 1
Sub macro1()
Optimise (False)

MyDir = MyPath = ActiveWorkbook.Path

sheetcount = 1

mysheets = ActiveWorkbook.Sheets.Count
For Count = mysheets + 1 To 20
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Sheet" & Count
Next

Columns("A:AF").Clear
Dim MyArray(32)
Dim MyArray2(32)

Offset = 0
For Count = 1 To 32

MyArray(Count) = 0
'MyArray2(Count) = 0 took this out to save memory

Next

MyArray2(32) = 0

Row = 0

Loop1:
Column = 32
Row = Row + 1
If Row > Rows.Count - 400 Then Row = 0: sheetcount = sheetcount + 1: Sheets("Sheet" & Sheetcout).Activate
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, 32)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 0: MyArray2(Column) = 0: Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

B C B 0 B B D 0 A

**hallwod** · 03-20-2016, 08:52 AM

The logic I was trying to work out an algorithm for was that (taking the easier 4 column example), we start with AAAA and then for each subsequent row cols 1 to 3 stay on A and col 4 increments +1. When col 4 =4 row 3 of col 5 would increment by 1 (i.e. become B) and col 4 of row 5 would start at B (i.e. the same as col 3 ) etc. Sorry if that's rather long hand bit it's where I got in a mess trying to implement! DJH

**shg** · 03-19-2016, 09:08 PM

You're welcome.

**mehmetcik** · 03-20-2016, 07:56 AM

I just ran the code without modification and stopped it at line 365715

0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 D C B 0 0 C B D

I will let it run to its conclusion.

**mehmetcik** · 03-20-2016, 12:13 PM

I would have expected your output to be:-

A A A A
A A A B
A A A C
A A A D
A A B A
A A B B
A A B C
A A B D
A A C A
A A C B
A A C C
A A C D
A A D A
A A D B
A A D C
A A D D
A B A A
A B A B
A B A C
A B A D
A B B A
A B B B
A B B C
A B B D
A B C A
A B C B
A B C C
A B C D
A B D A
A B D B
A B D C
A B D D
A C A A
A C A B
A C A C
A C A D
A C B A
A C B B
A C B C
A C B D
A C C A
A C C B
A C C C
A C C D
A C D A
A C D B
A C D C
A C D D
A D A A
A D A B
A D A C
A D A D
A D B A
A D B B
A D B C
A D B D
A D C A
A D C B
A D C C
A D C D
A D D A
A D D B
A D D C
A D D D
B A A A
B A A B
B A A C
B A A D
B A B A
B A B B
B A B C
B A B D
B A C A
B A C B
B A C C
B A C D
B A D A
B A D B
B A D C
B A D D
B B A A
B B A B
B B A C
B B A D
B B B A
B B B B
B B B C
B B B D
B B C A
B B C B
B B C C
B B C D
B B D A
B B D B
B B D C
B B D D
B C A A
B C A B
B C A C
B C A D
B C B A
B C B B
B C B C
B C B D
B C C A
B C C B
B C C C
B C C D
B C D A
B C D B
B C D C
B C D D
B D A A
B D A B
B D A C
B D A D
B D B A
B D B B
B D B C
B D B D
B D C A
B D C B
B D C C
B D C D
B D D A
B D D B
B D D C
B D D D
C A A A
C A A B
C A A C
C A A D
C A B A
C A B B
C A B C
C A B D
C A C A
C A C B
C A C C
C A C D
C A D A
C A D B
C A D C
C A D D
C B A A
C B A B
C B A C
C B A D
C B B A
C B B B
C B B C
C B B D
C B C A
C B C B
C B C C
C B C D
C B D A
C B D B
C B D C
C B D D
C C A A
C C A B
C C A C
C C A D
C C B A
C C B B
C C B C
C C B D
C C C A
C C C B
C C C C
C C C D
C C D A
C C D B
C C D C
C C D D
C D A A
C D A B
C D A C
C D A D
C D B A
C D B B
C D B C
C D B D
C D C A
C D C B
C D C C
C D C D
C D D A
C D D B
C D D C
C D D D
D A A A
D A A B
D A A C
D A A D
D A B A
D A B B
D A B C
D A B D
D A C A
D A C B
D A C C
D A C D
D A D A
D A D B
D A D C
D A D D
D B A A
D B A B
D B A C
D B A D
D B B A
D B B B
D B B C
D B B D
D B C A
D B C B
D B C C
D B C D
D B D A
D B D B
D B D C
D B D D
D C A A
D C A B
D C A C
D C A D
D C B A
D C B B
D C B C
D C B D
D C C A
D C C B
D C C C
D C C D
D C D A
D C D B
D C D C
D C D D
D D A A
D D A B
D D A C
D D A D
D D B A
D D B B
D D B C
D D B D
D D C A
D D C B
D D C C
D D C D
D D D A
D D D B
D D D C
D D D D

Created using this code:-


Option Base 1
Sub macro1()
'Optimise (False)

ColNo = 4
MyDir = MyPath = ActiveWorkbook.Path

sheetcount = 1

mysheets = ActiveWorkbook.Sheets.Count
For Count = mysheets + 1 To 20
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Sheet" & Count
Next

Cells.Clear
ReDim MyArray(ColNo)
ReDim MyArray2(ColNo)

Offset = 0
For Count = 1 To ColNo

MyArray(Count) = 1
MyArray2(Count) = "A"

Next

Row = 0

Loop1:
Column = 4
Row = Row + 1
If Row > Rows.Count - 400 Then Row = 0: sheetcount = sheetcount + 1: Sheets("Sheet" & Sheetcout).Activate
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, ColNo)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 1: MyArray2(Column) = "A": Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

**hallwod** · 03-20-2016, 01:24 PM

My thanks once again. This certainly works and I see you are expecting the required output to be all permutations of ABCD. However, order is not important so if you take line 2 at AAAB then line 5 is AABA which is the same combination. Hence my basic algorithm that when Col(x) contains D [or 4 if numeric] then on the next row Col (x-1) = previous row Col(x)-1 and this next row Col(x) starts at Col(x-1) on the same row.

So If say Row = 5 then
Col(1) =1
Col(2) =1
Col(3) = Col(3)+1 from Row 4
Col(4) now = Col(3)

and Col(4) continues to be incremented until it is 4 again and so on

Sorry again to be taking so much of your time but it's really appreciated. DJH

**shg** · 03-20-2016, 12:29 PM

Ah -- you're looking for draw with replacement.

The workbook at https://app.box.com/s/cj3cjtij207amp5q583161f97g6y8n8s does that.

**hallwod** · 03-20-2016, 01:48 PM

Thanks shg, it certainly gives the output but the options and hence the code is perhaps a little too complex for my needs. In addition I do need each element of each combination to be in its own column. I guess I could intercept the code to do that. I'm sure mehmetcik is so close with his last version.

**mehmetcik** · 03-20-2016, 08:02 PM

So if I give an A a value of 1
and a B a value of 10
and a C a value of 100
and a D a value of 1000

and calculate a value of each output in columns A to B in column F

I can then use countif to find the first occurrence of each result
I then delete all duplicates.

Looking forward, it would be quite simple to build in the countif during the first part of the macro, to delete duplicates as they are created.

A A A A
A A A B
A A A C
A A A D
A A B B
A A B C
A A B D
A A C C
A A C D
A A D D
A B B B
A B B C
A B B D
A B C C
A B C D
A B D D
A C C C
A C C D
A C D D
A D D D
B B B B
B B B C
B B B D
B B C C
B B C D
B B D D
B C C C
B C C D
B C D D
B D D D
C C C C
C C C D
C C D D
C D D D
D D D D

This is the code I used:-


Option Base 1
Sub macro1()
'Optimise (False)

ColNo = 4
MyDir = MyPath = ActiveWorkbook.Path

sheetcount = 1

mysheets = ActiveWorkbook.Sheets.Count
For Count = mysheets + 1 To 20
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Sheet" & Count
Next

Cells.Clear
ReDim MyArray(ColNo)
ReDim MyArray2(ColNo)

Offset = 0
For Count = 1 To ColNo

MyArray(Count) = 1
MyArray2(Count) = "A"

Next

Row = 1

Loop1:
Column = 4
Row = Row + 1
If Row > Rows.Count - 400 Then Row = 0: sheetcount = sheetcount + 1: Sheets("Sheet" & Sheetcout).Activate
Display = Display + 1


Range(Cells(Row, 1), Cells(Row, ColNo)).Value = MyArray2

Loop2:
If Column = 0 Then GoTo Quit
If MyArray(Column) = 4 Then MyArray(Column) = 1: MyArray2(Column) = "A": Column = Column - 1: GoTo Loop2
MyArray(Column) = MyArray(Column) + 1
MyArray2(Column) = Chr(MyArray(Column) + 64)

GoTo Loop1

Quit:

    Range("F2:F" & Row).FormulaR1C1 = _
        "=10^(FIND(RC[-5],""ABCD"")-1)+10^(FIND(RC[-4],""ABCD"")-1)+10^(FIND(RC[-3],""ABCD"")-1)+10^(FIND(RC[-2],""ABCD"")-1)"
    Range("H2:H" & Row).FormulaR1C1 = "=IF(COUNTIF(R1C[-2]:R[-1]C[-2],RC[-2])=0,ROW(),""0"")"
    
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("H2:H" & Row _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A2:H" & Row)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
   t = 5
   
   Set Z = Range("H2:H2" & Row).Find("0", LookIn:=xlValues, Lookat:=xlWhole)

    
    Rows(Z.Row & ":" & Row).Delete Shift:=xlUp

    Columns("F:H").Delete Shift:=xlToLeft
    Range("A2").Select

Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

**hallwod** · 03-22-2016, 01:23 PM

Once again my thanks. In the meantime I have been trying to solve the algorithm for mysef - the only way to learn!
Everything has worked as per the code below. However, there are a few things not going quite according to plan which it would be helpful if you could plesase look into. Firstly when the macro has run I seem to have "lost" all the menu ribbons. Sometimes the sheet has lost is auto calcualtion.
I'm tring to pass the numeric value from my numeric TempArray() as a character to my RealArray(x,y) but I'm getting a subscript error
Finally I thought I would be able to grab the values in cells from the worksheet and assign them to my vba variables. This works OK for anything other than a cell which contains a calculated value.
I have inserted the code into a new module - is that the correct way?
If you try and run the code you'll se what I mean. You'll need to put values in cells A2, B3 and B4 Suggest 56, 5 and 4 respectively.
I'm sure that once these few isues are ironed out I'll be able to continue unaided with my project! Thanks again. DJH


Option Base 1
Sub macro1()
Optimise (False)

MyDir = MyPath = ActiveWorkbook.Path
Dim Combinations As Integer

MyRow = 5
ColOffset = 10
CombCount = 0
Layouts = Cells(4, 2).Value
Panels = Cells(3, 2).Value
Combinations = Cells(2, 2).Value
Column = Panels

Columns("K:BB").Clear

ReDim TempArray(Panels)
ReDim RealArray(Combinations, Panels)


'Initiate first Combination to A,A,A,A,A, etc., and set Temporary Panel/Col values all to 1


For Count = 1 To Panels
TempArray(Count) = 1
RealArray(1, Count) = Chr(1 + 64)
Next

'--------------------------------------------------------------------
'Display first combination

Range(Cells(MyRow, ColOffset), Cells(MyRow, (Panels + ColOffset - 1))).Value = TempArray
'Display = Display + 1

'----------------------------------------------------------------------

'Main Loop and Routine exit condition

Loop1:
If CombCount > Panels Then GoTo Quit

MyRow = MyRow + 1
'Display = Display + 1

'Loop round incrementing value in final Panel/Column position by 1

For Count = 1 To Panels
If Count = Column Then
TempArray(Count) = TempArray(Count) + 1
End If

RealArray(MyRow, Count) = Chr(TempArray(Count) + 64)       'Changes Layout Number to Letter "A", "B" etc

Next

Range(Cells(MyRow, ColOffset), Cells(MyRow, (Panels + ColOffset - 1))).Value = TempArray        'Displays Combinations row by row with Layout Number

'when final Column contains the last layout value.......

If TempArray(Panels) = Layouts Then
CombCount = 0

'Count how many Panels/Columns contain the last Layout value

For Temp1 = Panels To 1 Step -1
If TempArray(Temp1) = Layouts Then
CombCount = CombCount + 1
End If
Next
'-------------------------------------
If CombCount = Panels Then GoTo Quit            'If all Panels/Columns contain the last layout Value then the Routine is complete


TempArray(Panels - CombCount) = TempArray(Panels - CombCount) + 1  'Set the value of the Panel/Column immediately preceeding
                                                                                                                    'the column in which the value= last Layout value
                                                                                                                    'to 1 + the value of that coulmn in thepreceeding Row

'backtrack along the Panels/Columns and replace the TempArray(Panel/Column) with the value calualted above

For Temp2 = (Panels - CombCount) To (Panels - 1)
TempArray(Temp2) = TempArray(Panels - CombCount)
Next
TempArray(Panels) = TempArray(Panels - CombCount) - 1       'set the value of the final Panel/Column to value calculated above
                                                                                                    'but deduct 1 as its value is incremented when the Loopbegins again
End If

GoTo Loop1



Quit:
Optimise (True)
End Sub
Sub Optimise(Flag As Boolean)
On Error Resume Next
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
Application.DisplayStatusBar = Flag
ActiveSheet.DisplayPageBreaks = Flag
If Flag = False Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
On Error GoTo 0
End Sub

Hybrid View

vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Re: vba code for Combinations

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Combinations without repetition - VBA code partially working

[SOLVED] VBA code to calculate Average value of number combinations

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions