sudoku type problem

[methody]

Hello there
Not sure if this is possible but I thought I would ask.
I have the numbers 1 to 16 in cells A1 to P1.
In the next 15 rows I want the numbers 1 to 16 to be arranged in such a way that every row and every column has the numbers 1 to 16 (across and down sum of 136)
There are two further problems:
1. The first 3 rows are set:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
2 1 15 14 13 12 11 10 16 8 7 6 5 4 3 9
8 7 10 15 14 16 2 1 11 3 9 13 12 5 4 6


2. As the numbers are filled in, if 8 is put in column 1, 1 must be put in column 8 - see above.

I am basically looking for one solution - there may be more. I thought code might help but it might not be possible.

 

[methody]

Hello Glenn
that is very close. sometimes it does exactly right but sometimes it seems to overide the numbers. I can't really pinpoint when it does and when it doesn't. When I put 4 and 5 under columns 5 and 4 it doesn't seems to work.

thanks

 

[GlennUK]

I'd guess that when it doesn't find a solution ( for example when only 15 and 16 are left for columns 15 and 16, but those numbers have both already been used in both columns ), the macro clears the row to try again.

This may solve that problem:

Sub fillactivesheet()
    Dim iguess(16) As Variant
    iadjust = 0
    Application.Calculation = xlCalculationManual
    For irow = 4 To 999 ' do 999 tries - not guaranteed to work, as iterations to solution is random, and the current try may be an invalid solution anyway
        If (irow - iadjust) = 17 Then Exit For ' matrix is filled

        ' store initial guesses
        For istore = 1 To 16
            iguess(istore) = Cells(irow - iadjust, istore).Value
        Next
        For icol = 1 To 16
            If Cells(irow - iadjust, icol) = "" Then
                'pick a number that hasn't been picked before
                For i = 1 To 16
                    ipick = ActiveWorkbook.Sheets("Sheet2").Cells(i, 2) ' pick a random next value
                    blnused = False
                    ' check all previous cells in the column
                    For Each c In Range(Cells(1, icol), Cells((irow - iadjust) - 1, icol))
                        If c.Value = ipick Then
                            blnused = True
                            Exit For
                        End If
                    Next
                    ' check all other cells in the row
                    For icolpos = 1 To 16
                        If icol <> icolpos Then
                            Set c = Cells(irow - iadjust, icolpos)
                            If c.Value <> "" Then
                                If c.Value = ipick Then
                                    blnused = True
                                    Exit For
                                End If
                            End If
                        End If
                    Next
                    
                    If Not blnused Then
                        newnum = ipick
                        Exit For
                    End If
                Next
                Cells(irow - iadjust, icol) = newnum
                If Cells(irow - iadjust, newnum) <> "" Then
                    ' it's not working, so try to do this row again
                    Cells(irow - iadjust, 1).Resize(1, 16).ClearContents
                    For istore = 1 To 16
                        If iguess(istore) <> "" Then Cells(irow - iadjust, istore) = iguess(istore)
                    Next
                    Application.Calculate
                    iadjust = iadjust + 1
                Else
                    Cells(irow - iadjust, newnum) = icol
                End If
                
            End If
        Next
    Next
                    
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

[methody]

I think that's perfect now.
I appreciate the time you've given to this.
thank you very much

 

[GlennUK]

It's my pleasure.

Good luck with it all.

 

[methody]

Hello Glenn
I don't know if you will see this or remember what it was about but I have anotheer follow up.

You had produced code to generate numbers in a grid which I was using for fixtures for a sports competition.
Numbers 1 to 16 were along the top (the teams) and your code generated numbers in successive rows (15 -one for each week of matches) below. If 7 was under 1 then 1 would be under 7 indicated that 1 would be playing 7 and 7 would be playing 1.

This has been brilliant although I have manually had to decide wwhich team was at home and which was away.

I was wondering if it would be possible automated this in any way. I was thinking that a similar sized grid could be filled in directly below with As and Hs representing home and away. If the first grid was in rows 1 to 16 the home away grid would start in row 17.
In effect 8 A's and 8 H's would 'randomly' be distributed across the row except it would not be totally random as if 1 was playing 7 and 1 had been given a H then 7 would have to get an A. This then would be repeated for each of the rows in the number grid. It would also need to try to ensure that each team got a balance number of homes and aways (or as close to balance as possible). So going down the columns there would only be 7 or 8 h's or a's.
Hope this is clear
Don't know if this is possible at all but I would appreciate any thoughts

 

[shg]

Is this to set up a round-robin tournament?

 

[methody]

Yes that's right

 

[shg]

There's a workbook that does this at http://www.box.com/s/z41sn0yrp5lo1cuozke3

 

[methody]

This is an extension of the problem above.
The code initially filled in all the cells perfectly. Then I asked for an additional constraint in where sometimes I might have a few numbers already filled in. I got an answer which basically did this. This meant however that the the code sometimes might not find a solution and in fact occasionally it gave an incorrect solution.
I was trying to create a check to see if the solution was correct and if it wasn't it would go back to the start. The check came down to range (v13)had to equal 90
The slight problem is that if I had already entered a few cells I needed it to go back to the point where there were those same cells entered. I added a simple bit of code whereby

Having initally manually entered a few cells

the macro would
copy the starting range A point to another range B.
then run fillactivesheet
if a solution could not be found or if the check was not right then basically go back to the start copying range B back to range A and keep repeating until.

I was hoing that it be some sort of simple loop but perhaps not