Generate specific matrix

I posted this on the other board too.....

this may not help but it handle the matrix for n =2 to n = 5
you could mimic/extend the coding for n = 6, etc
maybe someone else knows how to handle this better

Sub macro1()
' clear old matrix
Range("A1").Select
Selection.CurrentRegion.ClearContents
'
' Read in n value
'
n = Range("nvalue").Value
i = 0
a = 1
If n = 2 Then GoTo two
If n = 3 Then GoTo three
If n = 4 Then GoTo four
If n = 5 Then GoTo five
two:
new2i:
i = i + 1
j = 0
new2j:
j = j + 1
Cells(a, 1) = i
Cells(a, 2) = j
a = a + 1
If j < 2 And j - i < 1 Then GoTo new2j Else GoTo incr2i
incr2i:
If i < 1 Then GoTo new2i Else GoTo done
three:
new3i:
i = i + 1
k = 0
j = 0
new3j:
j = j + 1
k = 0
new3k:
k = k + 1
Cells(a, 1) = i
Cells(a, 2) = j
Cells(a, 3) = k
a = a + 1
If k < 3 And k - j < 1 Then GoTo new3k Else GoTo incr3j
incr3j:
If j < 2 And j - i < 1 Then GoTo new3j Else GoTo incr3i
incr3i:
If i < 1 Then GoTo new3i Else GoTo done
four:
new4i:
i = i + 1
k = 0
j = 0
l = 0
new4j:
j = j + 1
k = 0
l = 0
new4k:
k = k + 1
l = 0
new4l:
l = l + 1
Cells(a, 1) = i
Cells(a, 2) = j
Cells(a, 3) = k
Cells(a, 4) = l
a = a + 1
If l < n And l - k < 1 Then GoTo new4l Else GoTo incr4k
incr4k:
If k < 3 And k - j < 1 Then GoTo new4k Else GoTo incr4j
incr4j:
If j < 2 And j - i < 1 Then GoTo new4j Else GoTo incr4i
incr4i:
If i < 1 Then GoTo new4i Else GoTo done
five:
new5i:
i = i + 1
k = 0
j = 0
l = 0
new5j:
j = j + 1
k = 0
l = 0
new5k:
k = k + 1
l = 0
new5l:
l = l + 1
m = 0
new5m:
m = m + 1
Cells(a, 1) = i
Cells(a, 2) = j
Cells(a, 3) = k
Cells(a, 4) = l
Cells(a, 5) = m
a = a + 1
If m < n And m - l < 1 Then GoTo new5m Else GoTo incr5l
incr5l:
If l < n And l - k < 1 Then GoTo new5l Else GoTo incr5k
incr5k:
If k < 3 And k - j < 1 Then GoTo new5k Else GoTo incr5j
incr5j:
If j < 2 And j - i < 1 Then GoTo new5j Else GoTo incr5i
incr5i:
If i < 1 Then GoTo new5i Else GoTo done
done:
End Sub

Sub test()
Dim a(99)
m = 4
limit = WorksheetFunction.Fact(m)

For y = 0 To limit - 1
n = m
x = y

For j = m To 1 Step -1
a(j) = x Mod n + 1

If n = 1 Then GoTo skip

x = (x - (x Mod n)) / n
n = n - 1
Next j

skip:
counter = counter + 1
MsgBox counter
MsgBox a(1) & a(2) & a(3) & a(4) & a(5)

Next y
End Sub

Our modified code yields 42 rows of data;
Chu's code yields 24 rows
Meawhile, our mathematician is very quiet

=====
Sub t()
Cells.Clear
n = 5
y = 0
For i = 1 To n - 3
For j = 1 To n - 2
For k = 1 To n - 1
For l = 1 To n
y = y + 1
Cells(y, 1) = i
Cells(y, 2) = j
Cells(y, 3) = k
Cells(y, 4) = l
Next l
Next k
Next j
Next i
icol = 1
For irow = Cells(65536, 4).End(xlUp).Row To 1 Step -1
If Cells(irow, icol) > Cells(irow, icol + 1) Or Cells(irow, icol
+ 1) > Cells(irow, icol + 2) _
Or Cells(irow, icol + 2) > Cells(irow, icol + 3) Then
Rows(irow).Delete
Next irow
End Sub

"chu@pacificcigar.com" wrote:

> Sub test()
> Dim a(99)
> m = 4
> limit = WorksheetFunction.Fact(m)
>
> For y = 0 To limit - 1
> n = m
> x = y
>
> For j = m To 1 Step -1
> a(j) = x Mod n + 1
>
> If n = 1 Then GoTo skip
>
> x = (x - (x Mod n)) / n
> n = n - 1
> Next j
>
> skip:
> counter = counter + 1
> MsgBox counter
> MsgBox a(1) & a(2) & a(3) & a(4) & a(5)
>
> Next y
> End Sub
>
>

Many thanks for effort
Script below don't seem to give good result
But I think the script given by Bernie MS Excel MVP on as follow is perfect
even
unfortunatly matrix over the work sheet I must work on another constraint to
have specific combination
Many thanks Bernie
Many thanks for you all
Regards
Mjiyed


Sub test()
Dim mySize As Integer

mySize = Application.InputBox("What n do you want to do?", _
"Matrix Creation", , , , , , 1)
MakeMatrix mySize
End Sub

Sub MakeMatrix(n As Integer)
Dim i As Integer
Dim j As Integer
Dim myRow As Long
Dim myCol As Integer
Dim myCell As Range
Dim NotDone As Boolean
Dim myMax As Integer
Dim myMaxC As Integer

Set myCell = ActiveCell

'Create First 2 Rows
For myCol = 1 To n
myCell(1, myCol).Value = 1
myCell(2, myCol).Value = 1
Next myCol
myCell(2, n).Value = 2

myRow = 2
NotDone = False

For myCol = 1 To n - 1
If myCell(myRow, myCol).Value <> _
myCell(myRow, myCol + 1).Value - 1 Then
NotDone = True
End If
Next myCol

While NotDone

myCell(myRow, 1).Resize(1, n).Copy myCell(myRow + 1, 1)
myRow = myRow + 1

myMax = Application.Max(myCell(myRow, 1).Resize(1, n))
myMaxC = Application.CountIf(myCell(myRow, 1).Resize(1, n), myMax)

If myMaxC = 1 And myCell(myRow, n).Value = myMax Then
For i = n - 1 To 2 Step -1
If myCell(myRow, i).Value < myCell(myRow, i + 1).Value - 1 Then
myCell(myRow, i).Value = myCell(myRow, i).Value + 1
For j = i + 1 To n
myCell(myRow, j).Value = 1
Next j
GoTo Changed:
End If

If myCell(myRow, i).Value = myCell(myRow, i - 1).Value Then
myCell(myRow, i).Value = myCell(myRow, i).Value + 1
For j = i + 1 To n
myCell(myRow, j).Value = 1
Next j
GoTo Changed:
End If
Next i
End If

If myCell(myRow, n).Value <> myMax And myMaxC = 1 Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value <> myMax Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value = myMax And myMaxC <> 1 Then
myCell(myRow, n).Value = myCell(myRow, n).Value + 1
GoTo Changed:
End If

If myCell(myRow, n).Value = myMax And myMaxC = 1 Then
myCell(myRow, n - 1).Value = myCell(myRow, n - 1).Value + 1
myCell(myRow, n).Value = 1
GoTo Changed:
End If

Changed:

'Check Again
NotDone = False
For myCol = 1 To n - 1
If myCell(myRow, myCol).Value <> _
myCell(myRow, myCol + 1).Value - 1 Then
NotDone = True
End If
Next myCol

Wend

End Sub