Vorige Pagina About the Author

'Collects the second, third and fourth 5 x 5 square (all elements different) based on the first
'The fifth square is calculated

' Tested with Office 2007 under Windows 7

Sub SudCube5b()

Dim a1(125), a2(5, 25), a3(25), s3(4), s2(3, 10), b(5)
Dim txt1 As String, txt2 As String, t1 As String

Sheets("Klad1").Select

y = MsgBox("Locked", vbCritical, "Routine SudCube5b")
End

Sht1 = "SudSqrs5"                                       'input sheet

n3 = 4288                                               'number of squares to be checked, 240 Pan Magic Sudoku51
                                                        '                                 960 Magic     Sudoku52
                                                        '                                4288 Magic     SudSqr5
k1 = 1: k2 = 1: n20 = 0                                 'Print parameters

t1 = Timer

'   reading a2(1,i4): Square 1
    n1 = 2: n2 = 2                                      'start row : column
    n4 = 0: i4 = 0                                      'current square

'   reading a2(2,i24): Square 2
    n21 = 2: n22 = 2                                    'start row : column
    n24 = 0: i24 = 0                                    'current square

'   reading a2(3,i34): Square 3
    n31 = 2: n32 = 2                                    'start row : column
    n34 = 0: i34 = 0                                    'current square

'   reading a2(4,i44): Square 4
    n41 = 2: n42 = 2                                    'start row : column
    n44 = 0: i44 = 0                                    'current square

Cells(n9 + 1, 125).Select
For j3 = 1 To n3                                        'Square nr j3 current
    n4 = n4 + 1: n2 = 2 + (n4 - 1) * 6: i4 = 0
    Cells(n9 + 1, 127).Value = j3
    
    For j1 = n1 To n1 + 4                               'Row    within square j3
        For j2 = n2 To n2 + 4                           'Column within square j3
            i4 = i4 + 1
            a2(1, i4) = Sheets(Sht1).Cells(j1, j2).Value          'load square 1
        Next j2
    Next j1
    If a2(1, 13) = 2 Then GoTo 10                        'Only a2(3, 13) = 2 for Spacediagonals
    
If n4 < 4 Then
    n24 = n4: n21 = n1
Else
    n24 = 0: n21 = n1 + 6
End If
    
    For j23 = 1 To n3                                   'Square nr j23 to be checked
        n24 = n24 + 1: n22 = 2 + (n24 - 1) * 6: i24 = 0
        SqrNr2 = Sheets(Sht1).Cells(n21 - 1, n22).Value
        Cells(n9 + 1, 128).Value = SqrNr2
        If SqrNr2 = 0 Then GoTo 10                      'End of range
        
        For j21 = n21 To n21 + 4                        'Row    within square j23
            For j22 = n22 To n22 + 4                    'Column within square j23
                i24 = i24 + 1
                a2(2, i24) = Sheets(Sht1).Cells(j21, j22).Value    'load square 2
            Next j22
        Next j21
        If a2(2, 13) = 2 Then GoTo 20                   'Only a2(3, 13) = 2 for Spacediagonals
        
        GoSub 100                                       'Check all elements Square 2 and 1
        If fl1 = 0 Then
   
If n24 < 4 Then
    n34 = n24: n31 = n21
Else
    n34 = 0: n31 = n21 + 6
End If
    
        For j33 = 1 To n3                                    'Square nr j33 to be checked
            n34 = n34 + 1: n32 = 2 + (n34 - 1) * 6: i34 = 0
            SqrNr3 = Sheets(Sht1).Cells(n31 - 1, n32).Value
            Cells(n9 + 1, 129).Value = SqrNr3
            If SqrNr3 = 0 Then GoTo 20                       'End of range

            For j31 = n31 To n31 + 4                         'Row    within square j33
                For j32 = n32 To n32 + 4                     'Column within square j33
                    i34 = i34 + 1
                    a2(3, i34) = Sheets(Sht1).Cells(j31, j32).Value        'load square 3
                Next j32
            Next j31
            If a2(3, 13) <> 2 Then GoTo 30                   'a2(3, 13) = 2 for Spacediagonals

            GoSub 200                                        'Check all elements Square 3 and 1,2
            If fl2 = 0 Then
 
If n34 < 4 Then
    n44 = n34: n41 = n31
Else
    n44 = 0: n41 = n31 + 6
End If
 
            For j43 = 1 To n3                                   'Square nr j43 to be checked
                n44 = n44 + 1: n42 = 2 + (n44 - 1) * 6: i44 = 0
                SqrNr4 = Sheets(Sht1).Cells(n41 - 1, n42).Value
                Cells(n9 + 1, 130).Value = SqrNr4
                If SqrNr4 = 0 Then GoTo 30                      'End of range
 
                For j41 = n41 To n41 + 4                        'Row    within square j43
                    For j42 = n42 To n42 + 4                    'Column within square j43
                        i44 = i44 + 1
                        a2(4, i44) = Sheets(Sht1).Cells(j41, j42).Value      'load square 4
                    Next j42
                Next j41

                GoSub 300                                       'Check all elements Square 4 and 1,2,3
                If fl3 = 0 Then
                      
                   For j10 = 1 To 25                            'Complete Cube
                           a2(5, j10) = 10 - a2(1, j10) - a2(2, j10) - a2(3, j10) - a2(4, j10)
                   Next j10
                        
                   For j20 = 1 To 5
                       For j10 = 1 To 25
                           a1((5 - j20) * 25 + j10) = a2(j20, j10)
                       Next j10
                   Next j20
                        
                   n9 = n9 + 1: GoSub 500                      'Print Cube (selected numbers)
''                 n9 = n9 + 1: GoSub 600                      'Print Cube (5 plane view)
                        
                End If
40              If n44 = 4 Then n44 = 0: n41 = n41 + 6: n42 = 2
                Next j43

        End If
30      If n34 = 4 Then n34 = 0: n31 = n31 + 6: n32 = 2
        Next j33
        
    End If
20  If n24 = 4 Then n24 = 0: n21 = n21 + 6: n22 = 2
    Next j23
    
10  If n4 = 4 Then n4 = 0: n1 = n1 + 6: n2 = 2
    Next j3

t2 = Timer
    
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SudCube5b")

End
    
'   Check all elements Square 1 differ from all elements of Square 2

100 fl1 = 1
    For j10 = 1 To 25: a3(j10) = 0: Next j10
    For j10 = 1 To 25
        If a2(2, j10) = a2(1, j10) Then a3(j10) = 1
    Next j10
    n10 = 0
    For j10 = 1 To 25
        If a3(j10) = 0 Then n10 = n10 + 1              'count unequal element
    Next j10
    If n10 = 25 Then fl1 = 0
    
    Return
    
'   Check all elements Square 3 differ from all elements of Square 2 and 1
    
200 fl2 = 1
    For j10 = 1 To 25: a3(j10) = 0: Next j10
    For j10 = 1 To 25
        If a2(3, j10) = a2(1, j10) Then a3(j10) = 1
        If a2(3, j10) = a2(2, j10) Then a3(j10) = 1
    Next j10
    n10 = 0
    For j10 = 1 To 25
        If a3(j10) = 0 Then n10 = n10 + 1              'count unequal element
    Next j10
    If n10 = 25 Then fl2 = 0
    
    Return
    
'   Check all elements Square 4 differ from all elements of Square 3, 2 and 1
    
300 fl3 = 1
    For j10 = 1 To 25: a3(j10) = 0: Next j10
    For j10 = 1 To 25
        If a2(4, j10) = a2(1, j10) Then a3(j10) = 1
        If a2(4, j10) = a2(2, j10) Then a3(j10) = 1
        If a2(4, j10) = a2(3, j10) Then a3(j10) = 1
    Next j10
    n10 = 0
    For j10 = 1 To 25
        If a3(j10) = 0 Then n10 = n10 + 1               'count unequal element
    Next j10
    If n10 = 25 Then fl3 = 0
    Return
    
'   Print results (selected numbers)

500 Cells(n9, 125).Select
    For i1 = 1 To 125
        Cells(n9, i1).Value = a1(i1)
    Next i1
    
    Return

'   Print results (planes 11, 12, 13, 14 and 15)

600 n20 = n20 + 1
    If n20 = 7 Then
        n20 = 1: k1 = k1 + 30: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 6
    End If
       
    Cells(k1, k2).Select: y = MsgBox("Test", 0, "Test")
    For i0 = 1 To 5
         i3 = (5 - i0) * 25
         For i1 = 1 To 5
             For i2 = 1 To 5
                 i3 = i3 + 1
                 Cells(k1 + i1 + (i0 - 1) * 6, k2 + i2).Value = a1(i3)
             Next i2
         Next i1
         If i0 = 1 Then
             Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0) + ", C" + CStr(n9)
         Else
             Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0)
         End If
   Next i0
    
   Return

End Sub

Vorige Pagina About the Author