About the Author

' Row Generators based on Base Generators and Bimagic Series
' 7 Magic Rows, 1 Magic Column

' Tested with Office 365 under Windows 10

Sub RowGen7()

Dim a(49), a1(7), a2(7), b(67)
Dim n(67, 2)
Dim Ln7(7)

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

    k1 = 1: k2 = 1: n9 = 0
    ShtNm1 = "BaseLns7"     'Pre Selected Odd Series j10 = 2 to 425
    ShtNm2 = "Bima7b"       'Remaining Bimagic Series
    s1 = 175
    
    Sheets("Klad1").Select
    
'   Applicable Ranges in ShtNm2
    
    For i1 = 2 To 50
        i2 = Sheets(ShtNm2).Cells(i1, 13).Value
        n(i2, 1) = Sheets(ShtNm2).Cells(i1, 14).Value    'from
        n(i2, 2) = Sheets(ShtNm2).Cells(i1, 15).Value    'to
    Next i1
    
'   Select Remaining Series

    t1 = Timer

For j10 = 2 To 425

'   First Line

    Ln7(1) = 1
    n10 = 7: Erase a, b
    
    For i1 = 1 To 7
        a(i1) = Sheets(ShtNm1).Cells(j10, i1).Value
    Next i1
    For i1 = 1 To 7
        b(a(i1)) = a(i1)
    Next i1

    For i1 = 8 To 13
        i2 = Sheets(ShtNm1).Cells(1, i1).Value
        a(i2) = Sheets(ShtNm1).Cells(j10, i1).Value
    Next i1

    m2 = a(8):  m3 = a(15): m4 = a(22)
    m5 = a(29): m6 = a(36): m7 = a(43)

'   Lines 2, 3, 4, 5, 6, 7

    For j2 = n(m2, 1) To n(m2, 2)
    j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20
    Ln7(2) = j2

    For j3 = n(m3, 1) To n(m3, 2)
    j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30
    Ln7(3) = j3
   
    For j4 = n(m4, 1) To n(m4, 2)
    j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40
    Ln7(4) = j4

    For j5 = n(m5, 1) To n(m5, 2)
    j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50
    Ln7(5) = j5

    For j6 = n(m6, 1) To n(m6, 2)
    j300 = j6: GoSub 100: If fl1 = 0 Then GoTo 60
    Ln7(6) = j6
   
    For j7 = n(m7, 1) To n(m7, 2)
    j300 = j7: GoSub 100: If fl1 = 0 Then GoTo 70
    Ln7(7) = j7

       GoSub 500: If fl1 = 0 Then GoTo 5    'Back Check

''       n9 = n9 + 1: GoSub 650               'Print results (squares)
         n9 = n9 + 1: GoSub 640               'Print results (lines)
5
       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
70     Next j7
       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
60     Next j6
       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
50     Next j5

       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
40     Next j4
       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
30     Next j3
       For i1 = n10 - 7 + 1 To n10: b(a(i1)) = 0: Next i1
       n10 = n10 - 7
20     Next j2

Next j10

    t2 = Timer

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

End

'   Construct Semi Magic Squares

100 fl1 = 1

    For i1 = 1 To 7
        a2(i1) = Sheets(ShtNm2).Cells(j300, i1).Value
        If b(a2(i1)) <> 0 Then fl1 = 0: Return
    Next i1

    For i1 = 1 To 7
        b(a2(i1)) = a2(i1)
    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 Identical Numbers

500 fl1 = 1

    For i1 = 1 To 49
        a20 = a(i1)
        For i2 = i1 + 1 To 49
            If a(i2) = a20 Then fl1 = 0: Return
        Next i2
    Next i1
    
    Return

'   Print Results (Lines)
   
640 i3 = 0
    For i3 = 1 To 49
        Cells(n9, i3).Value = a(i3)
    Next i3
    Cells(n9, 50).Value = j10
    Cells(n9, 51).Value = n9
    Cells(1, 52).Value = j10
    Cells(1, 53).Value = n9
    
    Return

'   Print Results (Squares)

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).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    Cells(k1, k2 + 2).Value = j10
    Cells(1, 1).Value = n9
    
    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

About the Author