Volgende Pagina About the Author

' Generates Simple Magic Squares of Subtraction (11 x 11)
' Part II, Resulting Magic Diagonals

' Tested with Office 365 under Windows 10

Sub CnstrSqrs11b()

Dim a(121), a1(11), a2(11)

Dim a3(11, 11), a4(11, 11), a5(22), d1(11), d2(11)
Dim b(121), Line11(11)

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

Sheets("Klad1").Select

n1 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 671
Res11 = 61

ShtNm1 = "GenLns11"
ShtNm2 = "ScrSht11"

t1 = Timer

'   Read Semi Magic Squares

For j100 = 116 To 116
Cells(1, 1).Value = j100

    For i1 = 1 To 121
        a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
    Next i1
    
'      Check Possible Diagonals
    
       GoSub 200: If fl1 = 0 Then GoTo 5    'Write Sets 'ScrSht11'
       GoSub 400: If n29 = 0 Then GoTo 5    'Check Valid Sets

5

1000 Next j100

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

End

'   Check Possibility Diagonals

200 fl1 = 1

    i2 = 1: i3 = 0
    For i1 = 1 To 121:
         i3 = i3 + 1: If i3 = 12 Then i3 = 1: i2 = i2 + 1
         a3(i2, i3) = a(i1)
    Next i1

    i31 = 0
    For i11 = 1 To 11
    
y = MsgBox("i11 = " + CStr(i11), 0, "Test")
    
    For i12 = 1 To 11
    If i12 = i11 Then GoTo 220
    For i13 = 1 To 11
    If i13 = i11 Or i13 = i12 Then GoTo 230
    For i14 = 1 To 11
    If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
    For i15 = 1 To 11
    If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
    For i16 = 1 To 11
    If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
    For i17 = 1 To 11
    If i17 = i11 Or i17 = i12 Or i17 = i13 Or i17 = i14 Or i17 = i15 Or i17 = i16 Then GoTo 270
    For i18 = 1 To 11
    If i18 = i11 Or i18 = i12 Or i18 = i13 Or i18 = i14 Or i18 = i15 Or i18 = i16 Or i18 = i17 Then GoTo 280
    For i19 = 1 To 11
    If i19 = i11 Or i19 = i12 Or i19 = i13 Or i19 = i14 Or i19 = i15 Or i19 = i16 Or i19 = i17 Then GoTo 290
    If i19 = i18 Then GoTo 290
    For i20 = 1 To 11
    If i20 = i11 Or i20 = i12 Or i20 = i13 Or i20 = i14 Or i20 = i15 Or i20 = i16 Or i20 = i17 Then GoTo 320
    If i20 = i18 Or i20 = i19 Then GoTo 320
    For i21 = 1 To 11
    If i21 = i11 Or i21 = i12 Or i21 = i13 Or i21 = i14 Or i21 = i15 Or i21 = i16 Or i21 = i17 Then GoTo 330
    If i21 = i18 Or i21 = i19 Or i21 = i20 Then GoTo 330
    
    s11 = a3(1, i11) + a3(2, i12) + a3(3, i13) + a3(4, i14) + a3(5, i15) + a3(6, i16) + a3(7, i17) + a3(8, i18) + a3(9, i19) + a3(10, i20) + a3(11, i21)
    If s11 <> s1 Then GoTo 330

Erase b, Line11
b(a3(1, i11)) = a3(1, i11)
b(a3(2, i12)) = a3(2, i12)
b(a3(3, i13)) = a3(3, i13)
b(a3(4, i14)) = a3(4, i14)
b(a3(5, i15)) = a3(5, i15)
b(a3(6, i16)) = a3(6, i16)
b(a3(7, i17)) = a3(7, i17)
b(a3(8, i18)) = a3(8, i18)
b(a3(9, i19)) = a3(9, i19)
b(a3(10, i20)) = a3(10, i20)
b(a3(11, i21)) = a3(11, i21)
    
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 330
   
    i31 = i31 + 1
    
    Sheets(ShtNm2).Cells(i31, 11).Value = a3(1, i11)
    Sheets(ShtNm2).Cells(i31, 12).Value = a3(2, i12)
    Sheets(ShtNm2).Cells(i31, 13).Value = a3(3, i13)
    Sheets(ShtNm2).Cells(i31, 14).Value = a3(4, i14)
    Sheets(ShtNm2).Cells(i31, 15).Value = a3(5, i15)
    Sheets(ShtNm2).Cells(i31, 16).Value = a3(6, i16)
    Sheets(ShtNm2).Cells(i31, 17).Value = a3(7, i17)
    Sheets(ShtNm2).Cells(i31, 18).Value = a3(8, i18)
    Sheets(ShtNm2).Cells(i31, 19).Value = a3(9, i19)
    Sheets(ShtNm2).Cells(i31, 20).Value = a3(10, i20)
    Sheets(ShtNm2).Cells(i31, 21).Value = a3(11, i21)

330 Next i21
320 Next i20
290 Next i19
280 Next i18
270 Next i17
260 Next i16
250 Next i15
240 Next i14
230 Next i13
220 Next i12
210 Next i11

    If i31 < 2 Then fl1 = 0: Return

    n19 = 0
    For j11 = 1 To i31
 
    n20 = 11: Erase a5
    For i1 = 1 To 11
        a1(i1) = Sheets(ShtNm2).Cells(j11, i1 + 10).Value
    Next i1
    For i1 = 1 To 11   'First Line
        a5(i1) = a1(i1)
    Next i1
    
    For j12 = j11 + 1 To i31
    j300 = j12: GoSub 300: If fl2 = 0 Then GoTo 120

'      Write Set Diagonals to 'ScrSht11'

       For i1 = 1 To 2
            
            n19 = n19 + 1: If n19 > 15000 Then Return
            For i2 = 1 To 11
                 Sheets(ShtNm2).Cells(n19, i2 + 22).Value = a5(i2 + (i1 - 1) * 11)
            Next i2
            Sheets(ShtNm2).Cells(n19, 12 + 22).Value = i1
            
       Next i1

       n20 = n20 - 11
120    Next j12
       n20 = n20 - 11
110    Next j11

       If n19 < 2 Then fl1 = 0

Return

'   Construct Magic Set Diagonals

300 fl2 = 1

    For i1 = 1 To 11
        a2(i1) = Sheets(ShtNm2).Cells(j300, i1 + 10).Value
    Next i1

    n22 = 0
    For i1 = 1 To 11
    a20 = a2(i1)
    For i2 = 1 To n20
        If a20 = a5(i2) Then n22 = n22 + 1: i21 = i1: i22 = i2
    Next i2
    Next i1
    If n22 <> 1 Then fl2 = 0: Return    'Only one common allowed
    
 '  One Element Common (Center) ok
    
    n20 = n20 + 11: i22 = i22 + 11
    i2 = 0
    For i1 = n20 - 11 + 1 To n20
        i2 = i2 + 1
        a5(i1) = a2(i2)
    Next i1

    Return
    
'   Read Diagonals for Final Check

400
    n29 = 0
    For j20 = 1 To n19 - 1 Step 2
        
        For i1 = 1 To 11
            d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 22).Value
            d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 22).Value
        Next i1
     
        Erase a4
        For i1 = 1 To 11
        For i2 = 1 To 11
            If a3(i1, i2) = d1(i1) Then a4(i1, i2) = 1
            If a3(i1, i2) = d2(i1) Then a4(i1, i2) = 2
        Next i2
        Next i1

        GoSub 450      'Check if transformation is possible
        
        If fl1 = 1 Then
            n29 = n29 + 1
            
'           Print Semi Magic Squares
'           Required Transformation Highlighted
            n9 = n9 + 1: GoSub 650
        
        End If
    Next j20

    Return

'   Check if transformation is possible

450 fl1 = 1

    For i1 = 1 To 11                 'rows
        n21 = 0: i41 = 0: i42 = 0
        For i2 = 1 To 11             'clmns
            If a4(i1, i2) <> 0 Then
               n21 = n21 + 1
               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 11
            If a4(i3, i41) = 0 And a4(i3, i42) = 0 Then
                                     'continue
            Else
               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

650 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + 12: k2 = 1
    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
    
    i3 = 0
    For i1 = 1 To 11
        For i2 = 1 To 11
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
            
            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

'   Print results (squares)

750 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + 12: k2 = 1
    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
    
    i3 = 0
    For i1 = 1 To 11
        For i2 = 1 To 11
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
        Next i2
    Next i1

    Return

End Sub

Volgende Pagina About the Author