' Generates Semi Bimagic Squares of order 8, Magic Sum 260
' Based on 4 x 4 Half Generators
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs1501()
Dim a(64), a0(8, 8), a1(64), a2(64)
Dim n(8, 2)
y = MsgBox("Blocked", vbInformation, "ConstrSqrs1501")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 260: s2 = 11180
ShtNm1 = "HalfLns4"
ShtNm2 = "ScrSht8"
For j100 = 2 To 51
i2 = 1: i3 = 0
For i1 = 1 To 32:
i3 = i3 + 1: If i3 = 9 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
t1 = Sheets(ShtNm1).Cells(j100, 33)
For j200 = 52 To 101
i2 = 5: i3 = 0
For i1 = 1 To 32:
i3 = i3 + 1: If i3 = 9 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j200, i1)
Next i1
t2 = Sheets(ShtNm1).Cells(j200, 33)
Sheets(ShtNm2).Select
Cells.Select: Selection.ClearContents
Range("A1").Select
GoSub 500 ' Prepare Scratch Sheet
Sheets("Klad1").Select
For j1 = n(1, 1) To n(1, 2)
Cells(k1 + 1, 1).Select: Cells(k1 + 1, 1).Value = j1
n10 = 8: Erase a
For i1 = 1 To 8
a1(i1) = Sheets("ScrSht8").Cells(j1, i1).Value
Next i1
For i1 = 1 To 8 'First Line
a(i1) = a1(i1)
Next i1
For j2 = n(2, 1) To n(2, 2)
Cells(k1 + 2, 1).Select: Cells(k1 + 2, 1).Value = j2
j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20
For j3 = n(3, 1) To n(3, 2)
j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30
For j4 = n(4, 1) To n(4, 2)
j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40
For j5 = n(5, 1) To n(5, 2)
j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50
For j6 = n(6, 1) To n(6, 2)
j300 = j6: GoSub 100: If fl1 = 0 Then GoTo 60
For j7 = n(7, 1) To n(7, 2)
j300 = j7: GoSub 100: If fl1 = 0 Then GoTo 70
For j8 = n(8, 1) To n(8, 2)
j300 = j8: GoSub 100: If fl1 = 0 Then GoTo 80
n9 = n9 + 1: GoSub 650 'Print results (squares)
n10 = n10 - 8
80 Next j8
n10 = n10 - 8
70 Next j7
n10 = n10 - 8
60 Next j6
n10 = n10 - 8
50 Next j5
n10 = n10 - 8
40 Next j4
n10 = n10 - 8
30 Next j3
n10 = n10 - 8
20 Next j2
n10 = n10 - 8
10 Next j1
995
2000 Next j200
1000 Next j100
End
' Construct Semi Bimagic Squares
100 fl1 = 1
For i1 = 1 To 8
a2(i1) = Sheets("ScrSht8").Cells(j300, i1).Value
Next i1
For i1 = 1 To 8
a20 = a2(i1)
For i2 = 1 To n10
If a20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1
n10 = n10 + 8
i2 = 0
For i1 = n10 - 8 + 1 To n10
i2 = i2 + 1
a(i1) = a2(i2)
Next i1
Return
' Prepare Scratch Sheet
500
i9 = 0: n(1, 1) = 1
For i1 = 1 To 8
For i2 = 1 To 8
For i3 = 1 To 8
For i4 = 1 To 8
For i5 = 1 To 8
For i6 = 1 To 8
For i7 = 1 To 8
For i8 = 1 To 8
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)
If s11 <> s1 Then GoTo 580
s22 = a0(1, i1) ^ 2 + a0(2, i2) ^ 2 + a0(3, i3) ^ 2 + a0(4, i4) ^ 2 + a0(5, i5) ^ 2 + a0(6, i6) ^ 2 + a0(7, i7) ^ 2 + a0(8, i8) ^ 2
If s22 <> s2 Then GoTo 580
i9 = i9 + 1
Cells(i9, 1).Value = a0(1, i1)
Cells(i9, 2).Value = a0(2, i2)
Cells(i9, 3).Value = a0(3, i3)
Cells(i9, 4).Value = a0(4, i4)
Cells(i9, 5).Value = a0(5, i5)
Cells(i9, 6).Value = a0(6, i6)
Cells(i9, 7).Value = a0(7, i7)
Cells(i9, 8).Value = a0(8, i8)
580 Next i8
570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
n(i1, 2) = i9: If i1 <> 8 Then n(i1 + 1, 1) = i9 + 1
510 Next i1
n(8, 2) = i9
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
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 = t1
Cells(k1, k2 + 3).Value = t2
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Print results (lines)
660 Cells(n9, 65).Select
For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 65).Value = n9
Cells(n9, 66).Value = t1
Cells(n9, 67).Value = t2
Return
End Sub
