About the Author

' Constructs Associated Magic Squares of order 7
' Based on Symmetric Transformations of Square A {LDR Base Squares)

' Tested with Office 2007 under Windows 7

Sub CnstrLdr7()

Dim a(49), b(49), c(49), a2(7)
Dim a1(49), b1(49), c1(49)
Dim Dia1(7), Dia2(7)

y = MsgBox("Locked", vbExclamation, "Routine ChkLdr7b")
End

    n2 = 0: n9 = 0: k1 = 1: k2 = 1
    s1 = 175

Sheets("Klad1").Select

For j100 = 2 To 129

'   Read Base LDR

    For i1 = 1 To 49
        c1(i1) = Sheets("BaseLdr7").Cells(j100, i1).Value
    Next i1
    
'   Decompose c1()

    For i1 = 1 To 49
        a1(i1) = (c1(i1) - 1) Mod 7
        b1(i1) = (c1(i1) - a1(i1) - 1) / 7
    Next i1

j4 = 3: a2(4) = j4

For j1 = 0 To 6
If j1 = j4 Then GoTo 10
j7 = 6 - j1
a2(1) = j1: a2(7) = j7

For j2 = 0 To 6
If j2 = j1 Or j2 = j7 Or j2 = j4 Then GoTo 20
j6 = 6 - j2
If j6 = j1 Or j6 = j7 Or j6 = j4 Then GoTo 20
a2(2) = j2: a2(6) = j6

For j3 = 0 To 6
If j3 = j2 Or j3 = j1 Or j3 = j6 Or j3 = j7 Or j3 = j4 Then GoTo 30
j5 = 6 - j3
If j5 = j2 Or j5 = j1 Or j5 = j6 Or j5 = j7 Or j5 = j4 Then GoTo 30
a2(3) = j3: a2(5) = j5

    For i1 = 1 To 49
        a(i1) = a2(a1(i1) + 1)
        c(i1) = a(i1) + 7 * b1(i1) + 1
    Next i1
    
'   Check identical numbers
    
    GoSub 300: If fl1 = 0 Then GoTo 5

'   Check Ldr Format (Option)
    
    GoSub 500: If fl1 = 0 Then GoTo 5    

    n9 = n9 + 1: GoSub 650

5

30 Next j3
20 Next j2
10 Next j1

Next j100

End

'   Check identical numbers
    
300 fl1 = 1:
    For i1 = 1 To 49
       c2 = c(i1)
       For i2 = (1 + i1) To 49
           If c2 = c(i2) Then fl1 = 0: Return
       Next i2
    Next i1
    Return

'   Check Ldr Format

500 fl1 = 1

'   Dia c(1) ... c(49)
    
    i2 = 1
    For i1 = 1 To 7
        Dia1(i1) = c(i2): i2 = i2 + 8
    Next i1
    
    For i1 = 1 To 6
        If Dia1(i1) > Dia1(i1 + 1) Then fl1 = 0: Return
    Next i1
    MinDia1 = Dia1(1)
    
'   Dia c(7) ... c(43)
    
    MinDia2 = 49: i2 = 7
    For i1 = 1 To 7
        Dia2(i1) = c(i2): i2 = i2 + 6
        If MinDia2 > Dia2(i1) Then MinDia2 = Dia2(i1)
    Next i1
    
    If MinDia2 < MinDia1 Then fl1 = 0: Return
    If c(7) > c(43) Then fl1 = 0: Return

    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 = c(i3)
        Next i2
    Next i1
    Return

End Sub

About the Author