ALL NUMBERS

[verluc]

I have to create a sheet with 6 columns.
Each row must to be filled with a number between 1 and 42.
So I have to start with:
1 2 3 4 5 6
I need ALL the combinations who are possible
with the numbers 1 to 42
So the last row is:
37 38 39 40 41 42
What the difficult is : the difference between each column is not more then 15
So the difference between B and A or C and B or D and C or E and D or F and E is not more then 15
Who can write me a macro?
Many thanks in advance

[Tommy Bak]

Hi verluc
i have a macro that can do that, but it's a rewritten one.
You have to fill in the numbers from 1 - 42
in a 6 by 7 matrix. that is fx.
A B C D E F
1 1 2 3 4 5 6
2 7 8 9 10 ......

then run the macro. It will take a while (60 secs on p350)
I havn't had/taken the time to optimize it.


Option Base 1

Sub Combinations()
Dim Matrix As Variant
Dim NyMatrix()
Dim NoOfRowMatrix
Dim MaxColumns, MaxRows As Integer
Dim TR, repetion, a, i, y, p As Long
Dim z, x As Byte
MaxRows = 0
TR = 1
Set inarea = Application.InputBox("Input range ?", Type:=8)
Application.ScreenUpdating = False
MaxColumns = inarea.Columns.Count
MaxRows = inarea.Rows.Count
ReDim NoOfRowMatrix(MaxColumns)
For x = 1 To MaxColumns
For y = 1 To MaxRows
If Not IsEmpty(inarea.Cells(y, x)) Then NoOfRowMatrix(x) = NoOfRowMatrix(x) + 1
Next y
TR = TR * NoOfRowMatrix(x)
Next x
ReDim Matrix(MaxRows, MaxColumns)
Matrix = inarea

ReDim NyMatrix(TR, MaxColumns)
For z = 1 To MaxColumns
repetion = 1
For x = z + 1 To MaxColumns
repetion = repetion * NoOfRowMatrix(x)
Next x
a = 1
While a <= TR
For y = 1 To NoOfRowMatrix(z)
For i = 1 To repetion
NyMatrix(a, z) = Matrix(y, z)
a = a + 1
Next i
Next y
Wend
Next z
z = 0
For y = 1 To TR
ok = True
For x = 1 To MaxColumns - 1
If Abs(NyMatrix(y, x) - NyMatrix(y, x + 1)) > 15 Then
ok = False
Exit For
End If
Next x
If ok = True Then
z = z + 1
For p = 1 To MaxColumns
Cells(z + 10, p).Value = NyMatrix(y, p)
Next p
End If
Next y
Application.ScreenUpdating = True
End Sub

[Jay Petrulis]

You will not be able to get =COMBIN(42,6) to 6 columns on the worksheet, even bounded by the maximum difference.

The following routine will write what you want to the worksheet, but each combination will be in a single cell. You can use text-to-columns and separate by commas after you run this.

Please note, that any of these loops provided will be glacially slow. For smaller values of n, it is easy to load the values in an array and then load to the worksheet at one shot. I am still trying to do it for multiple columns. If I get it, I will post back.

Sub test()
Dim a As Integer, b As Integer, c As Integer, LoadCol As Integer
Dim d As Integer, e As Integer, f As Integer, x
Dim nums As Integer, maxdiff As Integer, Counter As Long

Application.ScreenUpdating = False

nums = 20
maxdiff = 15
LoadCol = 1

For a = 1 To nums - 5
    For b = a + 1 To WorksheetFunction.Min(a + maxdiff, nums - 4)
        For c = b + 1 To WorksheetFunction.Min(b + maxdiff, nums - 3)
            For d = c + 1 To WorksheetFunction.Min(c + maxdiff, nums - 2)
                For e = d + 1 To WorksheetFunction.Min(d + maxdiff, nums - 1)
                    For f = e + 1 To WorksheetFunction.Min(e + maxdiff, nums)
                        Counter = Counter + 1
                        Application.StatusBar = Counter
                        x = a & "," & b & "," & c & "," & d & "," & e & "," & f
                        If Cells(Rows.Count, LoadCol).Value <> "" Then LoadCol = LoadCol + 1
                        If Cells(1, LoadCol) = "" Then
                            Cells(1, LoadCol) = x
                        Else
                            Cells(Cells(Rows.Count, LoadCol).End(xlUp).Row + 1, LoadCol) = x
                        End If
                    Next f
                Next e
            Next d
        Next c
    Next b
Next a
Application.StatusBar = False
MsgBox "Processing complete" & vbCr & Format(Counter, "#,##0") & " entries loaded."
End Sub

I have given this with the "nums" value at 20, for you to test prior to working on the bigger scale. You should get 38,760 entries. Change it to 42 and be prepared to wait a long, long time for this to finish.

HTH,
Jay

[Tommy Bak]

Thanks Jay.
I was wrong in my way of doing this.
I did not get all the combination. I can see that clearly now after reading your post.

By the way I have tried your code, with the modification that I write (Print) x to a textfile instead. I got (with nums = 42) 3.774.976 combinations on 6 minutes with an AMD 350 mhz. Textfile size 64 mb.

regards Tommy

[Jay Petrulis]

On 2002-05-20 14:35, Tommy Bak wrote:
Thanks Jay.
I was wrong in my way of doing this.
I did not get all the combination. I can see that clearly now after reading your post.

By the way I have tried your code, with the modification that I write (Print) x to a textfile instead. I got (with nums = 42) 3.774.976 combinations on 6 minutes with an AMD 350 mhz. Textfile size 64 mb.

regards Tommy

Hi Tommy,

Please post your code amendments. I have never needed to print to a text output file, but now is as good a time as any to learn. And all the better as it is an improvement on what has been posted.

Bye,
Jay

[Tommy Bak]

Hi Jay
here is the code, but how would you read a textfile that into excel??
you would have to break it somehow.
(approx 1 minute on P1500)


I have also tried with reading x into an array and then dumping dumping that into the spreadsheet (column by column when a 65536 is reached). it work OK and fast for for nums up to 25, but when i tried it with Nums=42 i ran out of patience.

Option Base 1
Sub test()
Dim a, b, c, d, e, f As Byte
Dim LoadCol As Integer, x
Dim nums As Integer, maxdiff As Integer, Counter As Long
Dim filename1 As String
Start = Timer
filename1 = "C:testing.txt"
Application.ScreenUpdating = False
nums = 42
maxdiff = 15
LoadCol = 1
Open filename1 For Output As #1
For a = 1 To nums - 5
For b = a + 1 To WorksheetFunction.Min(a + maxdiff, nums - 4)
For c = b + 1 To WorksheetFunction.Min(b + maxdiff, nums - 3)
For d = c + 1 To WorksheetFunction.Min(c + maxdiff, nums - 2)
For e = d + 1 To WorksheetFunction.Min(d + maxdiff, nums - 1)
For f = e + 1 To WorksheetFunction.Min(e + maxdiff, nums)
Counter = Counter + 1
'Application.StatusBar = Counter
x = a & "," & b & "," & c & "," & d & "," & e & "," & f
Print #1, x
Next f
Next e
Next d
Next c
Next b
Next a
Application.StatusBar = False
Close #1
MsgBox "Processing complete" & vbCr & Format(Counter, "#,##0") & " entries loaded on " & Timer - Start & "secs"
End Sub

regards Tommy

[verluc]

On 2002-05-21 01:58, Tommy Bak wrote:
Hi Jay
here is the code, but how would you read a textfile that into excel??
you would have to break it somehow.
(approx 1 minute on P1500)


I have also tried with reading x into an array and then dumping dumping that into the spreadsheet (column by column when a 65536 is reached). it work OK and fast for for nums up to 25, but when i tried it with Nums=42 i ran out of patience.

Option Base 1
Sub test()
Dim a, b, c, d, e, f As Byte
Dim LoadCol As Integer, x
Dim nums As Integer, maxdiff As Integer, Counter As Long
Dim filename1 As String
Start = Timer
filename1 = "C:testing.txt"
Application.ScreenUpdating = False
nums = 42
maxdiff = 15
LoadCol = 1
Open filename1 For Output As #1
For a = 1 To nums - 5
For b = a + 1 To WorksheetFunction.Min(a + maxdiff, nums - 4)
For c = b + 1 To WorksheetFunction.Min(b + maxdiff, nums - 3)
For d = c + 1 To WorksheetFunction.Min(c + maxdiff, nums - 2)
For e = d + 1 To WorksheetFunction.Min(d + maxdiff, nums - 1)
For f = e + 1 To WorksheetFunction.Min(e + maxdiff, nums)
Counter = Counter + 1
'Application.StatusBar = Counter
x = a & "," & b & "," & c & "," & d & "," & e & "," & f
Print #1, x
Next f
Next e
Next d
Next c
Next b
Next a
Application.StatusBar = False
Close #1
MsgBox "Processing complete" & vbCr & Format(Counter, "#,##0") & " entries loaded on " & Timer - Start & "secs"
End Sub

regards Tommy

Many thanks Tom and Jay.It's a great one.
Tom,what do you mean with : Filename
and "Print x"
When I run your macro,then I receive at the end the message: XXXXX numbers with a time...
Is this the only thing of the macro,or is it possible to print out all these numbers?
Thanks for answer.

[Tommy Bak]

Hi verluc
If you explore your drive C you should be able to find a file called testing.txt in the root of drive C
This file contains all the combinations that the program has made.
If you copied the code be aware that you replace the double with only one.
My contribution simply opens a txt-file, put (print in vba) all results into that, and closes it again.

regards Tommy

[verluc]

On 2002-05-21 08:51, Tommy Bak wrote:
Hi verluc
If you explore your drive C you should be able to find a file called testing.txt in the root of drive C
This file contains all the combinations that the program has made.
If you copied the code be aware that you replace the double with only one.
My contribution simply opens a txt-file, put (print in vba) all results into that, and closes it again.

regards Tommy

Hi Tommy,
Still a little question.To make it easier to input the conditions,is it possible to make an inputbox with: Numbers : ......
Max.Difference :......

Second question: do I have to delete the textfile before run another one?
Many thanks

[Tommy Bak]

Hi again

question 1.
Insert these two lines

nums = CInt(InputBox("Numbers ?", "Numberinput"))
maxdiff = CInt(InputBox("Maximum difference ?", "Difference"))

and remove the two old lines

question 2.
No,you don't have to delete the old one first. It will automaticly be overwritten.

best of luck
Tommy