vba code for Combinations

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

vba code for Combinations

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

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

Looking for permutation code for alphahnumeric combinations

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

Modify Combinations Code

Macro/Code to get all possible combinations

Subscript out of range error using all possible combinations code

Code For Combinations

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions