' Associated Bimagic Squares (9 x 9)
' Based on Semi Bimagic Squares (Partly Crosswise Symmetric)
' Predefined Diagonal Sets (Symmetric Euler Series)
' Tested with Office 365 under Windows 10
Sub CnstrSqrs9c()
Dim a(81), a1(9), a2(9)
Dim a3(9, 9), a4(9, 9), a5(18), d1(9), d2(9) 'Select Diagonals
Dim a31(9, 9), a32(9, 9) 'Rewrite to Assocaited Bimagic Square
y = MsgBox("Blocked", vbInformation, "CnstrSqrs9c")
End
Sheets("Klad1").Select
n1 = 0: n9 = 0: k1 = 1: k2 = 1
ShtNm1 = "SemiLns92" 'Bimagic Generators
ShtNm2 = "ScrSht9" 'Predefinid Diagonal Sets
s1 = 369: s2 = 20049
t1 = Timer
For j100 = 2 To 2233
' Read Semi Magic Square
For i1 = 1 To 81
a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
i2 = 1: i3 = 0
For i1 = 1 To 81:
i3 = i3 + 1: If i3 = 10 Then i3 = 1: i2 = i2 + 1
a3(i2, i3) = a(i1)
Next i1
n19 = 168 'Predefined Diagonal Sets (84)
GoSub 400: If n29 = 0 Then GoTo 1000 'Check Valid Sets
'Print from Sub 400
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs9c")
End
' Read Diagonals for Final Check
400
n29 = 0
For j20 = 1 To n19 - 1 Step 2
For i1 = 1 To 9
d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 20).Value
d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 20).Value
Next i1
Erase a4
For i1 = 1 To 9
For i2 = 1 To 9
For i3 = 1 To 9 'Modified for Predefined Diagonal Sets
If a3(i1, i2) = d1(i3) Then a4(i1, i2) = 1
If a3(i1, i2) = d2(i3) Then a4(i1, i2) = 2
Next i3
Next i2
Next i1
GoSub 450 'Check if transformation is possible
If fl1 = 1 Then
n29 = n29 + 1
GoSub 600 'Construct Bimagic Squares
GoSub 610 'Check Associated
If fl2 = 0 Then GoTo 5
'' n9 = n9 + 1: GoSub 650 'Print Assocaited Bimagic Squares
n9 = n9 + 1: Cells(1, 1).Value = n9 'Counting
' Required Transformation Highlighted
'' n9 = n9 + 1: GoSub 750 'Print Semi Magic Squares
5
End If
Next j20
Return
' Check if transformation is possible
450 fl1 = 1
For i1 = 1 To 9 'rows
n21 = 0: i41 = 0: i42 = 0
For i2 = 1 To 9 'clmns
If a4(i1, i2) <> 0 Then
n21 = n21 + 1
If n21 > 2 Then fl1 = 0: Return 'More elements of one diagonal on row i1
'Modified for Predefined Diagonal Sets
If n21 = 1 Then i41 = i2 Else i42 = i2
End If
Next i2
If i41 = 0 Or i42 = 0 Then GoTo 460
For i3 = i1 + 1 To 9
If a4(i3, i41) = 0 And a4(i3, i42) = 0 Then
'continue
Else
If a4(i3, i41) = a4(i1, i41) Or a4(i3, i42) = a4(i1, i42) Then
fl1 = 0: Return '2 elements of one diagonal in row and/or column
'Modified for Predefined Diagonal Sets
End If
If a4(i3, i41) = a4(i1, i42) And a4(i3, i42) = a4(i1, i41) Then
Exit For 'ok
Else
fl1 = 0: Return 'no match
End If
End If
Next i3
460 Next i1
Return
' Print Semi Magic Squares
' Required Transformation Highlighted
750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
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 = n29
Cells(k1, k2 + 4).Value = j20 'Diagonal Set
Cells(k1, k2 + 5).Value = j100 'Semi Bimagic Square
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Cells(k1 + i1, k2 + i2 + 10).Value = a4(i1, i2)
Select Case a4(i1, i2)
Case 1
Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Case 2
Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Case 0
End Select
Next i2
Next i1
Return
' Construct Bimagic Square
' Only suitable for Partly Crosswise Symmetrical Semi Magic Squares
600
' Center Column
For i1 = 1 To 9
a31(i1, 5) = a3(i1, 1)
Next i1
i5 = 0: i6 = 10
For i4 = 2 To 8 Step 2
i5 = i5 + 1: i6 = i6 - 1
For i3 = 1 To 9
i2 = a4(i4, i3)
If i2 = 1 Then
For i1 = 1 To 9
a31(i1, i5) = a3(i1, i3)
Next i1
ElseIf i2 = 2 Then
For i1 = 1 To 9
a31(i1, i6) = a3(i1, i3)
Next i1
End If
Next i3
Next i4
' Center Column
For i1 = 1 To 9
a32(5, i1) = a31(1, i1)
Next i1
i5 = 0: i6 = 10
For i4 = 2 To 8 Step 2
i5 = i5 + 1: i6 = i6 - 1
For i1 = 1 To 9
a32(i5, i1) = a31(i4, i1)
Next i1
For i1 = 1 To 9
a32(i6, i1) = a31(i4 + 1, i1)
Next i1
Next i4
Return
' Check Associated Property
610 fl2 = 1
i3 = 10:
For i1 = 1 To 5
i3 = i3 - 1
If i1 = 5 Then i22 = 4 Else i22 = 9
i4 = 10
For i2 = 1 To i22
i4 = i4 - 1
If a32(i1, i2) + a32(i3, i4) <> 82 Then fl2 = 0: Return
Next i2
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 4 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
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 = n29
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
''i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a32(i1, i2)
Next i2
Next i1
Return
End Sub
