Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Fun with Macro
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Fun with Macro
Hi Cecil,
Try this website: http://www.magic-squares.de/general/.../magicsum.html ------------------------------------------------ ~~ Message posted from http://www.ExcelTip.com/ ~~ View and post usenet messages directly from http://www.ExcelForum.com/ |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Fun with Macro
Zantor,
Thanks & Regards, Cecil "zantor" wrote in message ... Hi Cecil, Try this website: http://www.magic-squares.de/general/.../magicsum.html ------------------------------------------------ ~~ Message posted from http://www.ExcelTip.com/ ~~ View and post usenet messages directly from http://www.ExcelForum.com/ |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro recorded... tabs & file names changed, macro hangs | Excel Worksheet Functions | |||
Macro Help Needed - Excel 2007 - Print Macro with Auto Sort | Excel Worksheet Functions | |||
My excel macro recorder no longer shows up when recording macro | Excel Discussion (Misc queries) | |||
My excel macro recorder no longer shows up when recording macro | Excel Discussion (Misc queries) | |||
Macro needed to Paste Values and prevent Macro operation | Excel Discussion (Misc queries) |