Fun with Macro

[Cecilkumara Fernando]

Dear All,
This macro will fill a right square (with odd number of rows) with numbers
from 1 to the (No. of Rows)^2, when added horizontally or vertically or
diagonally will give the same answer. Dose anybody knows the mechanism for a
right square with even number of rows.
Regards,
Cecil

Sub FillSquare()
If Selection.Columns.Count = 1 Or _
Selection.Columns.Count <> Selection.Rows.Count _
Or Selection.Columns.Count Mod 2 = 0 Then
MsgBox ("Select a square with 3 or more odd number of rows")
Exit Sub
End If
Selection.ClearContents
FRow = Selection.Row
LRow = Selection.Row + Selection.Rows.Count - 1
FCol = Selection.Column
LCol = Selection.Column + Selection.Columns.Count - 1
Cells(LRow, LCol + 1).ClearContents
Cells(FRow, FCol + Int(Selection.Rows.Count / 2)).Activate
For i = 1 To Selection.Rows.Count ^ 2
ActiveCell.Value = i
If ActiveCell.Row = FRow Then
Cells(LRow, ActiveCell.Column + 1).Activate
'End If
Else
Cells(ActiveCell.Row - 1, ActiveCell.Column + 1).Activate
End If
If ActiveCell.Column > LCol And ActiveCell.Row <> LRow Then
Cells(ActiveCell.Row, FCol).Activate
End If
If Not IsEmpty(ActiveCell) Then
Cells(ActiveCell.Row + 2, ActiveCell.Column - 1).Activate
End If
If ActiveCell.Row = LRow And ActiveCell.Column = LCol + 1 Then
Cells(FRow + 1, LCol).Activate
End If
Next i
RTot = Range(Cells(FRow, FCol), Cells(FRow, LCol)).Address(0, 0)
CTot = Range(Cells(FRow, FCol), Cells(LRow, FCol)).Address(0, 0)
With Cells(FRow, FCol - 1)
..Formula = "=sum(" & RTot & ")"
..Select
Selection.AutoFill Destination:= _
Range(Cells(FRow, FCol - 1), Cells(LRow, FCol - 1))
End With
With Cells(LRow + 1, FCol)
..Formula = "=sum(" & CTot & ")"
..Select
Selection.AutoFill Destination:= _
Range(Cells(LRow + 1, FCol), Cells(LRow + 1, LCol))
End With
i = FCol
j = LRow
Do Until j = FRow - 1
RDia = Cells(j, i).Address(0, 0) & "," & RDia
j = j - 1
i = i + 1
Loop
RDia = Left(RDia, Len(RDia) - 1)
Cells(LRow + 1, FCol - 1).Formula = _
"=sum(" & RDia & ")"
i = LCol
j = LRow
Do Until j = FRow - 1
LDia = Cells(j, i).Address(0, 0) & "," & LDia
j = j - 1
i = i - 1
Loop
LDia = Left(LDia, Len(LDia) - 1)
Cells(LRow + 1, LCol + 1).Formula = _
"=sum(" & LDia & ")"
End Sub

 

[zantor]

Hi Cecil,

Try this website:

http://www.magic-squares.de/general/squares/magicsum.html

 

[Cecilkumara Fernando]

Zantor,
Thanks & Regards,
Cecil