Vorige Pagina About the Author

' Generates Semi Magic Squares of Subtraction (7 x 7)
' Magic Rows and Columns, Resulting Magic Diagonals

' Tested with Office 365 under Windows 10

Sub CnstrSqrs7()

Dim a(49), a0(7, 7), a1(7), a2(7), s(16)
Dim n(7, 2)
Dim a3(7, 7), a4(7, 7), a5(16), d1(7), d2(7)
Dim b(49), Line7(7)

y = MsgBox("Blocked", vbExclamation, "CnstrSqrs7")
End

Sheets("Klad1").Select

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

ShtNm1 = "GenLns7"
ShtNm2 = "ScrSht7"

t1 = Timer

For j100 = 1 To 196

i2 = 1: i3 = 0
For i1 = 1 To 49:
    i3 = i3 + 1: If i3 = 8 Then i3 = 1: i2 = i2 + 1
    a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
s1 = 175                    'Magic Constant
Res7 = 25                   'Residuum

    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)
    
    n10 = 7: Erase a
    For i1 = 1 To 7
        a1(i1) = Sheets(ShtNm2).Cells(j1, i1).Value
    Next i1
    For i1 = 1 To 7         ' First Line
        a(i1) = a1(i1)
    Next i1
    
    For j2 = n(2, 1) To n(2, 2)
    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
   
       Nc9 = Nc9 + 1                        'Unchecked (Diagonals)
    
'      Check Possible Diagonals
    
       GoSub 200: If fl1 = 0 Then GoTo 5    'Write Sets 'ScrSht7'
       GoSub 400: If n29 = 0 Then GoTo 5    'Check Valid Sets
      
''     n9 = n9 + 1: GoSub 750               'Print Semi Magic Squares

                                            'Related number of Magic Squares Shown (n29)
5
       
       n10 = n10 - 7
70     Next j7
       n10 = n10 - 7
60     Next j6
       n10 = n10 - 7
50     Next j5
       n10 = n10 - 7
40     Next j4
       n10 = n10 - 7
30     Next j3
       n10 = n10 - 7
20     Next j2
       n10 = n10 - 7
10     Next j1
    
1000 Next j100

t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine CnstrSqrs7")
End
    
'   Construct Semi Magic Squares

100 fl1 = 1

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

    For i1 = 1 To 7
    a20 = a2(i1)
    For i2 = 1 To n10
        If a20 = a(i2) Then fl1 = 0: Return
    Next i2
    Next i1
    
    n10 = n10 + 7
    i2 = 0
    For i1 = n10 - 7 + 1 To n10
        i2 = i2 + 1
        a(i1) = a2(i2)
    Next i1

    Return
    
'   Check Possibility Diagonals (Magic)

200 fl1 = 1

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

    i19 = 0
    For i11 = 1 To 7
    For i12 = 1 To 7
    If i12 = i11 Then GoTo 220
    For i13 = 1 To 7
    If i13 = i11 Or i13 = i12 Then GoTo 230
    For i14 = 1 To 7
    If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
    For i15 = 1 To 7
    If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
    For i16 = 1 To 7
    If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
    For i17 = 1 To 7
    If i17 = i11 Or i17 = i12 Or i17 = i13 Or i17 = i14 Or i17 = i15 Or i17 = i16 Then GoTo 270
    
    s11 = a3(1, i11) + a3(2, i12) + a3(3, i13) + a3(4, i14) + a3(5, i15) + a3(6, i16) + a3(7, i17)
    If s11 <> s1 Then GoTo 270

Erase b, Line7
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)
    
q2 = 0
For q1 = 1 To 49
    If b(q1) = q1 Then
        q2 = q2 + 1: Line7(q2) = q1
    End If
Next q1
    
s12 = Line7(7) - Line7(6) + Line7(5) - Line7(4) + Line7(3) - Line7(2) + Line7(1)
If s12 <> Res7 Then GoTo 270
    
    i19 = i19 + 1
    
    Sheets(ShtNm2).Cells(i19, 11).Value = a3(1, i11)
    Sheets(ShtNm2).Cells(i19, 12).Value = a3(2, i12)
    Sheets(ShtNm2).Cells(i19, 13).Value = a3(3, i13)
    Sheets(ShtNm2).Cells(i19, 14).Value = a3(4, i14)
    Sheets(ShtNm2).Cells(i19, 15).Value = a3(5, i15)
    Sheets(ShtNm2).Cells(i19, 16).Value = a3(6, i16)
    Sheets(ShtNm2).Cells(i19, 17).Value = a3(7, i17)

270 Next i17
260 Next i16
250 Next i15
240 Next i14
230 Next i13
220 Next i12
210 Next i11

    If i19 < 2 Then fl1 = 0: Return

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

'      Write Set Diagonals to 'ScrSht6'

       For i1 = 1 To 2
            
            n19 = n19 + 1
            For i2 = 1 To 7
                 Sheets(ShtNm2).Cells(n19, i2 + 20).Value = a5(i2 + (i1 - 1) * 7)
            Next i2
            Sheets(ShtNm2).Cells(n19, 9 + 20).Value = i1

       Next i1

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

       If n19 < 2 Then fl1 = 0

Return
    
'   Construct Magic Set Diagonals
        
300 fl2 = 1

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

    n22 = 0
    For i1 = 1 To 7
    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 + 7: i22 = i22 + 7
    i2 = 0
    For i1 = n20 - 7 + 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 7
            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 7
        For i2 = 1 To 7
            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 7                 'rows
        n21 = 0: i41 = 0: i42 = 0
        For i2 = 1 To 7             '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 7
            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
        
'   Prepare Scratch Sheet

500

i9 = 0: n(1, 1) = 1

For i1 = 1 To 7
For i2 = 1 To 7
For i3 = 1 To 7
For i4 = 1 To 7
For i5 = 1 To 7
For i6 = 1 To 7
For i7 = 1 To 7

    s11 = a0(1, i1) + a0(2, i2) + a0(3, i3) + a0(4, i4) + a0(5, i5) + a0(6, i6) + a0(7, i7)
    If s11 <> s1 Then GoTo 570
 
Erase b, Line7
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)
    
q2 = 0
For q1 = 1 To 49
    If b(q1) = q1 Then
        q2 = q2 + 1: Line7(q2) = q1
    End If
Next q1
    
s12 = Line7(7) - Line7(6) + Line7(5) - Line7(4) + Line7(3) - Line7(2) + Line7(1)
If s12 <> Res7 Then GoTo 570
   
    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 = j100

570 Next i7
560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2
    
    n(i1, 2) = i9: If i1 <> 7 Then n(i1 + 1, 1) = i9 + 1

510 Next i1

    n(7, 2) = i9
   
    Return
    
'   Print Semi Magic Squares
'   Required Transformation Highlighted

650 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + 8: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 8
    End If

    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = Nc9 ''n9
    Cells(k1, k2 + 2).Value = n29
 
    Cells(k1, k2 + 7).Value = j100  'Generator  Magic Lines
    
    i3 = 0
    For i1 = 1 To 7
        For i2 = 1 To 7
            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 (Semi Magic Squares)
'   Related number of Magic Squares Shown (n29)
    
750 n2 = n2 + 1
    If n2 = 5 Then
        n2 = 1: k1 = k1 + 8: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 8
    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 + 7).Value = j100  'Generator  Magic Lines
    
    i3 = 0
    For i1 = 1 To 7
        For i2 = 1 To 7
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
        Next i2
    Next i1
   
    Return
    
End Sub

Vorige Pagina About the Author