Vorige Pagina About the Author

' Constructs Order 13 Simple Magic Squares, Consecutive Prime Numbers
' Based on Semi Magic Squares

' Tested with Office 365 under Windows 10

Sub CnstrSqrs13b()

Dim a(169), a1(13), a2(13)

Dim a3(13, 13), a4(13, 13), a5(26), d1(13), d2(13)

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

Sheets("Klad1").Select

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

ShtNm1 = "SemiLns13"
ShtNm2 = "ScrSht13"

t1 = Timer

'   Read Semi Bimagic Squares

For j100 = 1 To 1 ''10
Cells(1, 1).Value = j100

    For i1 = 1 To 169
        a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
    Next i1
    s1 = Sheets(ShtNm1).Cells(j100, 170).Value
    
'      Check Possible Diagonals
    
       GoSub 200: If fl1 = 0 Then GoTo 5    'Write Sets 'ScrSht13'
       GoSub 400: If n29 = 0 Then GoTo 5    'Check Valid Sets
       
''     n9 = n9 + 1: GoSub 750               'Print results (squares)
''End

5

1000 Next j100

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

End

'   Check Possibility Diagonals

200 fl1 = 1

    i2 = 1: i3 = 0
    For i1 = 1 To 169:
         i3 = i3 + 1: If i3 = 14 Then i3 = 1: i2 = i2 + 1
         a3(i2, i3) = a(i1)
    Next i1
    
    i31 = 0
    For i11 = 1 To 2 ''13                            '*** Reduced Collection ***
    
y = MsgBox("i11 = " + CStr(i11), 0, "Test")
    
    For i12 = 1 To 13
    If i12 = i11 Then GoTo 220
    For i13 = 1 To 13
    If i13 = i11 Or i13 = i12 Then GoTo 230
    For i14 = 1 To 13
    If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
    For i15 = 1 To 13
    If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
    For i16 = 1 To 13
    If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
    For i17 = 1 To 13
    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 13
    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 13
    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 13
    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 13
    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
    For i22 = 1 To 13
    If i22 = i11 Or i22 = i12 Or i22 = i13 Or i22 = i14 Or i22 = i15 Or i22 = i16 Or i22 = i17 Then GoTo 340 
    If i22 = i18 Or i22 = i19 Or i22 = i20 Or i22 = i21 Then GoTo 340
    For i23 = 1 To 13
    If i23 = i11 Or i23 = i12 Or i23 = i13 Or i23 = i14 Or i23 = i15 Or i23 = i16 Or i23 = i17 Then GoTo 350 
    If i23 = i18 Or i23 = i19 Or i23 = i20 Or i23 = i21 Or i23 = i22 Then GoTo 350
    
    s13 = 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) + a3(12, i22) + a3(13, i23)

    If s13 <> s1 Then GoTo 350
   
    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)
    Sheets(ShtNm2).Cells(i31, 22).Value = a3(12, i22)
    Sheets(ShtNm2).Cells(i31, 23).Value = a3(13, i23)

    If i11 = 1 And i31 = 100 Then GoTo 210                        '*** Reduced Collection ***
    If i11 = 2 And i31 = 1500 Then GoTo 210
 
350 Next i23
340 Next i22
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                                           '*** Define Alternative Starting Point j11 ***
                                                                 '*** As Required                           ***
     n20 = 13: Erase a5
    For i1 = 1 To 13
        a1(i1) = Sheets(ShtNm2).Cells(j11, i1 + 10).Value
    Next i1
    For i1 = 1 To 13   '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 'ScrSht8'

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

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

       If n19 < 2 Then fl1 = 0

Return

'   Construct Magic Set Diagonals

300 fl2 = 1

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

    n22 = 0
    For i1 = 1 To 13
    a20 = a2(i1)
    For i2 = 1 To n20
        If a20 = a5(i2) Then n22 = n22 + 1: i21 = i1: i122 = i2
    Next i2
    Next i1
    If n22 <> 1 Then fl2 = 0: Return    'Only one common allowed
    
 '  One Element Common (Center) ok
    
    n20 = n20 + 13: i122 = i122 + 13
    i2 = 0
    For i1 = n20 - 13 + 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 13
            d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 26).Value
            d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 26).Value
        Next i1
     
        Erase a4
        For i1 = 1 To 13
        For i2 = 1 To 13
            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 13                 'rows
        n21 = 0: i41 = 0: i42 = 0
        For i2 = 1 To 13             '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 13
            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 + 14: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 14
    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 13
        For i2 = 1 To 13
            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 + 14: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 14
    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 13
        For i2 = 1 To 13
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
        Next i2
    Next i1

    Return

End Sub

Vorige Pagina About the Author