Vorige Pagina About the Author

' Constructs Order 10 Simple Magic Squares, Integers 1 ... 100
' Based on Semi Magic Squares

' Tested with Office 365 under Windows 10

Sub CnstrSqrs10()

Dim a(100), a1(10), a2(10)

Dim a3(10, 10), a4(10, 10), a5(20), d1(10), d2(10)

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

Sheets("Klad1").Select

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

ShtNm1 = "SemiLns10"
ShtNm2 = "ScrSht10"

t1 = Timer

'   Read Semi Magic Squares

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

    For i1 = 1 To 100
        a(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
    Next i1
    s1 = Sheets(ShtNm1).Cells(j100, 101).Value
    
'      Check Possible Diagonals
    
       GoSub 200: If fl1 = 0 Then GoTo 5    'Write Sets 'ScrSht10'
       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 CnstrSqrs10b")

End

'   Check Possibility Diagonals

200 fl1 = 1

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

    i21 = 0
    For i11 = 1 To 10
    For i12 = 1 To 10
    If i12 = i11 Then GoTo 220
    For i13 = 1 To 10
    If i13 = i11 Or i13 = i12 Then GoTo 230
    For i14 = 1 To 10
    If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
    For i15 = 1 To 10
    If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
    For i16 = 1 To 10
    If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
    For i17 = 1 To 10
    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 10
    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 10
    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 10
    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
   
    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)
    If s11 <> s1 Then GoTo 320
   
    i21 = i21 + 1
    
    Sheets(ShtNm2).Cells(i21, 11).Value = a3(1, i11)
    Sheets(ShtNm2).Cells(i21, 12).Value = a3(2, i12)
    Sheets(ShtNm2).Cells(i21, 13).Value = a3(3, i13)
    Sheets(ShtNm2).Cells(i21, 14).Value = a3(4, i14)
    Sheets(ShtNm2).Cells(i21, 15).Value = a3(5, i15)
    Sheets(ShtNm2).Cells(i21, 16).Value = a3(6, i16)
    Sheets(ShtNm2).Cells(i21, 17).Value = a3(7, i17)
    Sheets(ShtNm2).Cells(i21, 18).Value = a3(8, i18)
    Sheets(ShtNm2).Cells(i21, 19).Value = a3(9, i19)
    Sheets(ShtNm2).Cells(i21, 20).Value = a3(10, i20)

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 i21 < 2 Then fl1 = 0: Return

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

'      Write Set Diagonals to 'ScrSht10'

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

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

       If n19 < 2 Then fl1 = 0

Return

'   Construct Magic Set Diagonals

300 fl2 = 1

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

    For i1 = 1 To 10
    a20 = a2(i1)
    For i2 = 1 To n20
        If a20 = a5(i2) Then fl2 = 0: Return
    Next i2
    Next i1
    
    n20 = n20 + 10
    i2 = 0
    For i1 = n20 - 10 + 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 10
            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 10
        For i2 = 1 To 10
            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 10                 'rows
        n21 = 0
        For i2 = 1 To 10             'clmns
            If a4(i1, i2) <> 0 Then
               n21 = n21 + 1
               If n21 = 1 Then i41 = i2 Else i42 = i2
            End If
        Next i2
        
        For i3 = i1 + 1 To 10
            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
        
    Next i1

    Return

'   Print Semi Magic Squares
'   Required Transformation Highlighted

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

    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    
    i3 = 0
    For i1 = 1 To 10
        For i2 = 1 To 10
            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 + 11: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 11
    End If

    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    
    i3 = 0
    For i1 = 1 To 10
        For i2 = 1 To 10
            i3 = i3 + 1
            Cells(k1 + i1, k2 + i2).Value = a(i3)
        Next i2
    Next i1

    Return

End Sub

Vorige Pagina About the Author