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.

 

[GlennUK]

Have a random seed area, like this:

Excel Workbook
	A	B
1	0.580791	7
2	0.351545	10
3	0.20471	14
4	0.543447	8
5	0.134721	15
6	0.305561	12
7	0.75883	3
8	0.723234	4
9	0.39945	9
10	0.967796	1
11	0.8109	2
12	0.682411	6
13	0.098637	16
14	0.342214	11
15	0.691809	5
16	0.275731	13
Sheet2

And then use this macro to try attempts to fill per your rules ... it seems to work ok:

Sub fillactivesheet()
    iadjust = 0
    Application.Calculation = xlCalculationManual
    For irow = 4 To 999 ' do 999 tries - not guaranteed to work, as iterations to solution is random
        If (irow - iadjust) = 17 Then Exit For ' matrix is filled
        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 previous cells in the row
                    If icol > 1 Then
                        For Each c In Range(Cells(irow - iadjust, 1), Cells(irow - iadjust, icol - 1))
                            If c.Value = ipick Then
                                blnused = True
                                Exit For
                            End If
                        Next
                    End If
                    
                    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
                    Application.Calculate
                    iadjust = iadjust + 1
                Else
                    Cells(irow - iadjust, newnum) = icol
                End If
                
            End If
        Next
    Next
                    
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

[Gerald Higgins]

As a brute force solution, you could probably set up a lot of helper cells to calculate the allowable values for each cell, as you manually input them, and use Data Validation to list them.

 

[methody]

Hello there
I haven't looked at Gerald's thought yet but Glenn that is absolutely brilliant. I thought it would be possible to get the 16 numbers fitted in a 'sudoku' way but didn't think it would be possible to accomodate the requirement about pairing off the numbers.

Thank you very much

 

[GlennUK]

Hello there
I haven't looked at Gerald's thought yet but Glenn that is absolutely brilliant. I thought it would be possible to get the 16 numbers fitted in a 'sudoku' way but didn't think it would be possible to accomodate the requirement about pairing off the numbers.

Thank you very much

My pleasure. I am curious though ... what are you using this for?

 

[Gerald Higgins]

To be honest, I'm only saying my suggestion is POSSIBLE, I'm certainly not suggesting it's easy, or the best solution. If Glenn's works, I'd go with that.

 

[methody]

Hello Glenn
It's actually a sports competition. The numbers are teams and i'm trying ot work out who they should all play.
you have been a big help
Thanks again

 

[GlennUK]

Hello Glenn
It's actually a sports competition. The numbers are teams and i'm trying ot work out who they should all play.
you have been a big help
Thanks again

Ah, right, I see.

I've been glad to help ... good luck.

 

[methody]

Hello Glenn
A follow up question.

What if I manually fill in a couple of cells in one row. eg in row 7 I enter 2 in column 6 and 6 in column 2 (in effect this would represent ensure that a particular match would be on a particular week eg Celtic V Rangers on New Years Day.)
Would it take a major adjustment to your macro to tell it to proceed in the normal way but taking heed of the match already entered ie leaving the numbers already entered.

Thank you

 

[GlennUK]

Hi, here's a tweaked macro:

Sub fillactivesheet()
    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
        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
                    Application.Calculate
                    iadjust = iadjust + 1
                Else
                    Cells(irow - iadjust, newnum) = icol
                End If
                
            End If
        Next
    Next
                    
    Application.Calculation = xlCalculationAutomatic
    
End Sub

... as before, you may need to try it out more than once for it to find a solution.