Vorige Pagina About the Author

' Generates Sudoku Comparable Squares of order 5 for integers 0 thru 4 (Sudoku Diagonals)
' This Macro is based on the devellopment of SudCube5

' Tested with Office 2007 under Windows 7

Sub SudSqr5a()

Dim a(125), a5(25), s(12)

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

n2 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 10
m1 = 0: m2 = 4
  
     Sheets("Klad1").Select
    
     t1 = Timer

'    Generate Squares
     
     For j125 = m1 To m2
     a(125) = j125
     For j124 = m1 To m2
     If j124 = j125 Then GoTo 1240                                 'Check Row
     a(124) = j124
     For j123 = m1 To m2
     If j123 = j124 Or j123 = j125 Then GoTo 1230                  'Check Row
     a(123) = j123
     For j122 = m1 To m2
     If j122 = j123 Or j122 = j124 Or j122 = j125 Then GoTo 1220   'Check Row
     a(122) = j122
     
     a(121) = s1 - a(122) - a(123) - a(124) - a(125): j121 = a(121)

     For j120 = m1 To m2
     If j120 = j125 Then GoTo 1200                                 'Check Colum
     a(120) = j120
     For j119 = m1 To m2
     If j119 = j120 Then GoTo 1190                                 'Check Row
     If j119 = j124 Or j119 = j125 Then GoTo 1190                  'Check Column and Diagonal
     a(119) = j119
     For j118 = m1 To m2
     If j118 = j119 Or j118 = j120 Then GoTo 1180                  'Check Row
     If j118 = j123 Then GoTo 1180                                 'Check Column
     a(118) = j118
     For j117 = m1 To m2
     If j117 = j118 Or j117 = j119 Or j117 = j120 Then GoTo 1170   'Check Row
     If j117 = j121 Or j117 = j122 Then GoTo 1170                  'Check Column and Diagonal
     a(117) = j117
     
     a(116) = s1 - a(117) - a(118) - a(119) - a(120): j116 = a(116)
     If j116 = j121 Then GoTo 1170                                 'Check Column

     For j115 = m1 To m2
     If j115 = j120 Or j115 = j125 Then GoTo 1150                  'Check Column
     a(115) = j115
     For j114 = m1 To m2
     If j114 = j115 Then GoTo 1140                                 'Check Row
     If j114 = j119 Or j114 = j124 Then GoTo 1140                  'Check Column
     a(114) = j114
     For j113 = m1 To m2
     If j113 = j114 Or j113 = j115 Then GoTo 1130                               'Check Row
     If j113 = j118 Or j113 = j123 Then GoTo 1130                               'Check Column
     If j113 = j119 Or j113 = j125 Or j113 = j117 Or j113 = j121 Then GoTo 1130 'Check Diagonals
     a(113) = j113
     For j112 = m1 To m2
     If j112 = j113 Or j112 = j114 Or j112 = j115 Then GoTo 1120   'Check Row
     If j112 = j117 Or j112 = j122 Then GoTo 1120                  'Check Column
     a(112) = j112
     
     a(111) = s1 - a(112) - a(113) - a(114) - a(115): j111 = a(111)
     If j111 = j116 Or j111 = j121 Then GoTo 1120                  'Check Column

     For j110 = m1 To m2
     If j110 = j115 Or j110 = j120 Or j110 = j125 Then GoTo 1100   'Check Column
     a(110) = j110
     
     a(109) = a(110) - a(113) + a(115) - a(117) + a(120) - a(121) + a(125): j109 = a(109)
     If a(109) < m1 Or a(109) > m2 Then GoTo 1100
     If j109 = j110 Then GoTo 1100                                 'Check Row
     If j109 = j114 Or j109 = j119 Or j109 = j124 Then GoTo 1100   'Check Column
     If j109 = j113 Or j109 = j117 Or j109 = j121 Then GoTo 1100   'Check Diagonal

     For j108 = m1 To m2
     If j108 = j109 Or j108 = j110 Then GoTo 1080                  'Check Row
     If j108 = j113 Or j108 = j118 Or j108 = j123 Then GoTo 1080   'Check Column
     a(108) = j108
     
     a(107) = (s1 - a(108) - a(109) - a(110) + a(111) - a(113) + a(116) - a(119) + a(121) - a(125)) / 2
     j107 = Int(a(107)): If j107 <> a(107) Then GoTo 1080
     If a(107) < m1 Or a(107) > m2 Then GoTo 1080
     
     If j107 = j108 Or j107 = j109 Or j107 = j110 Then GoTo 1080   'Check Row
     If j107 = j112 Or j107 = j117 Or j107 = j122 Then GoTo 1080   'Check Column
     If j107 = j113 Or j107 = j119 Or j107 = j125 Then GoTo 1080   'Check Diagonal
     
     a(106) = s1 - a(107) - a(108) - a(109) - a(110): If a(106) < m1 Or a(106) > m2 Then GoTo 1080
     j106 = a(106)
     If j106 = j111 Or j106 = j116 Or j106 = j121 Then GoTo 1080   'Check Column
          
     a(105) = s1 - a(109) - a(113) - a(117) - a(121): If a(105) < m1 Or a(105) > m2 Then GoTo 1080
     a(104) = s1 - a(109) - a(114) - a(119) - a(124): If a(104) < m1 Or a(104) > m2 Then GoTo 1080
     a(103) = s1 - a(108) - a(113) - a(118) - a(123): If a(103) < m1 Or a(103) > m2 Then GoTo 1080
     a(102) = s1 - a(107) - a(112) - a(117) - a(122): If a(102) < m1 Or a(102) > m2 Then GoTo 1080
     a(101) = s1 - a(102) - a(103) - a(104) - a(105): If a(101) < m1 Or a(101) > m2 Then GoTo 1080

     GoSub 800: If fl1 = 0 Then GoTo 1080    'Check last row
'    GoSub 900: If fl1 = 0 Then GoTo 1080    'Check Pan Diagonals
'    GoSub 950: If fl1 = 0 Then GoTo 1080    'Check Associated 

     n9 = n9 + 1
     GoSub 1740 'Print results (selected numbers)
'    GoSub 1750 'Print results (Squares)

1080 Next j108
1100 Next j110

1120 Next j112
1130 Next j113
1140 Next j114
1150 Next j115

1170 Next j117
1180 Next j118
1190 Next j119
1200 Next j120

1220 Next j122
1230 Next j123
1240 Next j124
1250 Next j125
 
     t2 = Timer
     t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
     y = MsgBox(t10, 0, "Routine SudSqr5a")
End

'   Check last row

800 fl1 = 1
    For j1 = 101 To 105
       a2 = a(j1)
       For j2 = (1 + j1) To 105
           If a2 = a(j2) Then fl1 = 0: GoTo 850
       Next j2
    Next j1
850 Return

'   Check Pan Diagonal

900  fl1 = 1
     For i1 = 1 To 25
        a5(i1) = a(100 + i1)
     Next i1
     
'    Pan Diagonals
    
     s(1) = a5(2) + a5(8) + a5(14) + a5(20) + a5(21)
     s(2) = a5(3) + a5(9) + a5(15) + a5(16) + a5(22)
     s(3) = a5(4) + a5(10) + a5(11) + a5(17) + a5(23)
     s(4) = a5(5) + a5(6) + a5(12) + a5(18) + a5(24)
        
     s(5) = a5(4) + a5(8) + a5(12) + a5(16) + a5(25)
     s(6) = a5(3) + a5(7) + a5(11) + a5(20) + a5(24)
     s(7) = a5(2) + a5(6) + a5(15) + a5(19) + a5(23)
     s(8) = a5(1) + a5(10) + a5(14) + a5(18) + a5(22)
     
     For i1 = 1 To 8
        If s(i1) <> s1 Then fl1 = 0: n10 = n10 + 1: Return
     Next i1

     Return

'    Check Associated

950  fl1 = 1: s2 = 4
     For i1 = 1 To 25
        a5(i1) = a(100 + i1)
     Next i1
     
'    Associated Pairs
    
     s(1) = a5(1) + a5(25): s(2) = a5(2) + a5(24):   s(3) = a5(3) + a5(23):   s(4) = a5(4) + a5(22):
     s(5) = a5(5) + a5(21): s(6) = a5(6) + a5(20):   s(7) = a5(7) + a5(19):   s(8) = a5(8) + a5(18):
     s(9) = a5(9) + a5(17): s(10) = a5(10) + a5(16): s(11) = a5(11) + a5(15): s(12) = a5(12) + a5(14):
     
     For i1 = 1 To 12
        If s(i1) <> s2 Then fl1 = 0: n10 = n10 + 1: Return
     Next i1

     Return

'    Print results (selected numbers)

1740 Cells(n9, 25).Select
     For i1 = 101 To 125
         Cells(n9, i1 - 100).Value = a(i1)
     Next i1
     Return

'    Print results (squares)

1750 For i1 = 1 To 25
        a5(i1) = a(100 + i1)
     Next i1
     
     n2 = n2 + 1
     If n2 = 5 Then
        n2 = 1: k1 = k1 + 6: k2 = 1
     Else
        If n9 > 1 Then k2 = k2 + 6
     End If

     Cells(k1, k2 + 1).Select
     Cells(k1, k2 + 1).Font.Color = -4165632
     Cells(k1, k2 + 1).Value = n9
    
     i3 = 0
     For i1 = 1 To 5
        For i2 = 1 To 5
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a5(i3)
        Next i2
     Next i1

     Return

End Sub 

Vorige Pagina About the Author