Vorige Pagina About the Author

' Generates Semi Magic Squares of Subtraction (11 x 11)
' Non Itterative (One Error)

' Tested with Office 365 under Windows 10

Sub SemiSqrs11()

Dim a(121), a0(11, 11), a1(11), a2(11)
Dim b(121), Line11(11)

y = MsgBox("Blocked", vbInformation, "SemiSqrs11")
End

n1 = 0: n9 = 0: k1 = 1: k2 = 16

s1 = 671
Res11 = 61

ShtNm1 = "GenLns11"

Sheets("Klad1").Select

t1 = Timer

For j100 = 1 To 95

    i2 = 1: i3 = 0
    For i1 = 1 To 121:
        i3 = i3 + 1: If i3 = 12 Then i3 = 1: i2 = i2 + 1
        a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
    Next i1

     i19 = 0
     For j200 = 1 To 11
         GoSub 500                 'Search for Subtractive Lines
         If fl1 = 0 Then Exit For  'Not Found
2000 Next j200

If j200 < 11 Then GoTo 1000

n9 = n9 + 1: GoSub 650

1000 Next j100

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

End

'   Search for Subtractive Lines

500 fl1 = 1

For i1 = j200 To 11
For i2 = j200 To 11
For i3 = j200 To 11
For i4 = j200 To 11
For i5 = j200 To 11
For i6 = j200 To 11
For i7 = j200 To 11
For i8 = j200 To 11
For i9 = j200 To 11
For i10 = j200 To 11
For i11 = j200 To 11

    s11 = a0(1, i1) + a0(2, i2) + a0(3, i3) + a0(4, i4) + a0(5, i5) + a0(6, i6) + a0(7, i7) + a0(8, i8) + a0(9, i9) + a0(10, i10) + a0(11, i11)
    If s11 <> s1 Then GoTo 610

Erase b, Line11
b(a0(1, i1)) = a0(1, i1)
b(a0(2, i2)) = a0(2, i2)
b(a0(3, i3)) = a0(3, i3)
b(a0(4, i4)) = a0(4, i4)
b(a0(5, i5)) = a0(5, i5)
b(a0(6, i6)) = a0(6, i6)
b(a0(7, i7)) = a0(7, i7)
b(a0(8, i8)) = a0(8, i8)
b(a0(9, i9)) = a0(9, i9)
b(a0(10, i10)) = a0(10, i10)
b(a0(11, i11)) = a0(11, i11)
    
q2 = 0
For q1 = 1 To 121
    If b(q1) = q1 Then
        q2 = q2 + 1: Line11(q2) = q1
    End If
Next q1
    
s12 = Line11(11) - Line11(10) + Line11(9) - Line11(8) + Line11(7) - Line11(6) + Line11(5) - Line11(4) + Line11(3) - Line11(2) + Line11(1)
If s12 <> Res11 Then GoTo 610
    
' Check Bimagic (Option)
    
''s12 = 0
''For q1 = 1 To 11
''    s12 = s12 + Line11(q1) ^ 2
''Next q1
''If s12 <> 54351 Then GoTo 610
    
'   *** Test ***
    
    i19 = i19 + 1
    Cells(i19, 1).Value = a0(1, i1)
    Cells(i19, 2).Value = a0(2, i2)
    Cells(i19, 3).Value = a0(3, i3)
    Cells(i19, 4).Value = a0(4, i4)
    Cells(i19, 5).Value = a0(5, i5)
    Cells(i19, 6).Value = a0(6, i6)
    Cells(i19, 7).Value = a0(7, i7)
    Cells(i19, 8).Value = a0(8, i8)
    Cells(i19, 9).Value = a0(9, i9)
    Cells(i19, 10).Value = a0(10, i10)
    Cells(i19, 11).Value = a0(11, i11)
    
    Cells(i19, 12).Value = j100
    Cells(i19, 13).Value = j200
    Cells(i19, 13).Select

'  Swap Variables

   a1(1)  = a0(1, i1): a1(2) = a0(2, i2): a1(3) = a0(3, i3): a1(4) = a0(4, i4): a1(5) = a0(5, i5)
   a1(6)  = a0(6, i6): a1(7) = a0(7, i7): a1(8) = a0(8, i8): a1(9) = a0(9, i9): a1(10) = a0(10, i10)
   a1(11) = a0(11, i11)
   
   a0(1, i1) = a0(1, j200)
   a0(2, i2) = a0(2, j200)
   a0(3, i3) = a0(3, j200)
   a0(4, i4) = a0(4, j200)
   a0(5, i5) = a0(5, j200)
   a0(6, i6) = a0(6, j200)
   a0(7, i7) = a0(7, j200)
   a0(8, i8) = a0(8, j200)
   a0(9, i9) = a0(9, j200)
   a0(10, i10) = a0(10, j200)
   a0(11, i11) = a0(11, j200)
   
   For j1 = 1 To 11
       a0(j1, j200) = a1(j1)
   Next j1
   
   Return

610 Next i11
600 Next i10
590 Next i9
580 Next i8
570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
510 Next i1
    
    fl1 = 0
    
    Return

'   Print results (squares)

650 n2 = n2 + 1
    If n2 = 3 Then
        n2 = 1: k1 = k1 + 12: k2 = 16
    Else
        If n9 > 1 Then k2 = k2 + 12
    End If

''  Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    Cells(k1, k2 + 2).Value = j100
    Cells(k1, k2 + 3).Value = j200 - 1
    
    i3 = 0
    For i1 = 1 To 11
        For i2 = 1 To 11
            Cells(k1 + i1, k2 + i2).Value = a0(i1, i2)
        Next i2
    Next i1

    Return

End Sub

Vorige Pagina About the Author