About the Author

' Constructs Composed Magic Squares of order 7
' Based on Order 5 Latin Diagonal Squares and Order 7 Semi-Latin Borders

' Tested with Office 2007 under Windows 7

Sub CmbSqrs7()

    Dim a7(49), a(25), d3(2), b(7), n72(7)
    
    Sheets("Klad1").Select
    
y = MsgBox("Locked", vbExclamation, "Routine CmbSqrs7")
End

     n2 = 0: n9 = 0: k1 = 1: k2 = 1
     s1 = 175
    
     t1 = Timer
    
     For j100 = 2 To 2049                                     'Read Borders
    
         For i1 = 1 To 49
             a7(i1) = Sheets("Lines7").Cells(j100, i1).Value
         Next i1
         d3(1) = Sheets("Lines7").Cells(j100, 52).Value
         d3(2) = Sheets("Lines7").Cells(j100, 53).Value
        
         j71 = Sheets("Lines7").Cells(j100, 50).Value
         j72 = Sheets("Lines7").Cells(j100, 51).Value
        
'        Define Corner Square (3 x 3), Only 8 possible
    
         a7(1) = 28: a7(2) = 4:   a7(3) = 43:
         a7(8) = 46: a7(9) = 22:  a7(10) = 7:
         a7(15) = 1: a7(16) = 49: a7(17) = 25:
        
         For j200 = 2 To 2305	                              'Read Corner Squares

             d31 = Sheets("Crnr5").Cells(j200, 28).Value
             d32 = Sheets("Crnr5").Cells(j200, 29).Value
            
             j51 = Sheets("Crnr5").Cells(j200, 26).Value
             j52 = Sheets("Crnr5").Cells(j200, 27).Value
            
             If d31 <> d3(1) Or d32 <> d3(2) Then GoTo 2000   'Check Diagonal
            
             For i1 = 1 To 25
                 a(i1) = Sheets("Crnr5").Cells(j200, i1).Value
             Next i1
            
'            Complete a7()
            
             a7(17) = a(1):  a7(18) = a(2):  a7(19) = a(3):  a7(20) = a(4):  a7(21) = a(5):
             a7(24) = a(6):  a7(25) = a(7):  a7(26) = a(8):  a7(27) = a(9):  a7(28) = a(10):
             a7(31) = a(11): a7(32) = a(12): a7(33) = a(13): a7(34) = a(14): a7(35) = a(15):
             a7(38) = a(16): a7(39) = a(17): a7(40) = a(18): a7(41) = a(19): a7(42) = a(20):
             a7(45) = a(21): a7(46) = a(22): a7(47) = a(23): a7(48) = a(24): a7(49) = a(25):
            
'            Check identical numbers
            
             GoSub 300: If fl1 = 0 Then GoTo 1000
            
'            n9 = n9 + 1: Cells(1, 1).Value = n9    'Counting
'            n9 = n9 + 1: GoSub 640                 'Print results (selected numbers)
             n9 = n9 + 1: GoSub 650                 'Print results (squares)
    
2000 Next j200
1000 Next j100
    
     t2 = Timer
    
     t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
     y = MsgBox(t10, vbInformation, "Routine CmbSqrs7")
    
End

'   Check identical numbers
    
300 fl1 = 1: n10 = 0
    For i1 = 1 To 49
       a2 = a7(i1): If a2 = 0 Then GoTo 305
       For i2 = (1 + i1) To 49
           If a2 = a7(i2) Then fl1 = 0: Return
       Next i2
305 Next i1
    Return

'   Print results (selected numbers)

640 Cells(n9, 50).Select
    For i1 = 1 To 49
        Cells(n9, i1).Value = a7(i1)
    Next i1
    Cells(n9, 50).Value = n9
    Return

'   Print results (squares)

650 n1 = n1 + 1
    If n1 = 5 Then
        n1 = 1: k1 = k1 + 8: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 8
    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 7
        For i2 = 1 To 7
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a7(i3)
        Next i2
    Next i1
    Return

End Sub

About the Author