|
|
About the Author |
' Generates Magic Cubes of order 3 for integers 1 thru 27
' Tested with Office 2007 under Windows 7Sub MgcCube3() Dim a(27), b(27), c(27) y = MsgBox("Locked", vbCritical, "Routine MgcCube3") End n2 = 0: n9 = 0: k1 = 1: k2 = 1 m1 = 1: m2 = 27: s1 = 42 ' Generate data Sheets("Klad1").Select t1 = Timer For j27 = m1 To m2 'a(27) If b(j27) = 0 Then b(j27) = j27: c(27) = j27 Else GoTo 270 a(27) = j27 For j26 = m1 To m2 'a(26) If b(j26) = 0 Then b(j26) = j26: c(26) = j26 Else GoTo 260 j25 = s1 - j26 - j27 If j25 < m1 Or j25 > m2 Then GoTo 250 'a(25) If b(j25) = 0 Then b(j25) = j25: c(25) = j25 Else GoTo 250 a(26) = j26 a(25) = j25 For j24 = m1 To m2 'a(24) If b(j24) = 0 Then b(j24) = j24: c(24) = j24 Else GoTo 240 a(24) = j24 For j23 = m1 To m2 'a(23) If b(j23) = 0 Then b(j23) = j23: c(23) = j23 Else GoTo 230 a(23) = j23 a(22) = s1 - a(23) - a(24): If a(22) < m1 Or a(22) > m2 Then GoTo 220 a(21) = s1 - a(24) - a(27): If a(21) < m1 Or a(21) > m2 Then GoTo 220 a(20) = s1 - a(23) - a(26): If a(20) < m1 Or a(20) > m2 Then GoTo 220 a(19) = -s1 + a(23) + a(24) + a(26) + a(27): If a(19) < m1 Or a(19) > m2 Then GoTo 220 a(18) = -2 * s1 / 3 + a(23) + a(24) + a(26): If a(18) < m1 Or a(18) > m2 Then GoTo 220 a(17) = 4 * s1 / 3 - a(23) - 2 * a(26): If a(17) < m1 Or a(17) > m2 Then GoTo 220 a(16) = s1 / 3 - a(24) + a(26): If a(16) < m1 Or a(16) > m2 Then GoTo 220 a(15) = 4 * s1 / 3 - a(23) - 2 * a(24): If a(15) < m1 Or a(15) > m2 Then GoTo 220 a(14) = s1 / 3 a(13) = -2 * s1 / 3 + a(23) + 2 * a(24): If a(13) < m1 Or a(13) > m2 Then GoTo 220 a(12) = s1 / 3 + a(24) - a(26): If a(12) < m1 Or a(12) > m2 Then GoTo 220 a(11) = -2 * s1 / 3 + a(23) + 2 * a(26): If a(11) < m1 Or a(11) > m2 Then GoTo 220 a(10) = 4 * s1 / 3 - a(23) - a(24) - a(26): If a(10) < m1 Or a(10) > m2 Then GoTo 220 a(9) = 5 * s1 / 3 - a(23) - a(24) - a(26) - a(27): If a(9) < m1 Or a(9) > m2 Then GoTo 220 a(8) = -s1 / 3 + a(23) + a(26): If a(8) < m1 Or a(8) > m2 Then GoTo 220 a(7) = -s1 / 3 + a(24) + a(27): If a(7) < m1 Or a(7) > m2 Then GoTo 220 a(6) = -s1 / 3 + a(23) + a(24): If a(6) < m1 Or a(6) > m2 Then GoTo 220 a(5) = 2 * s1 / 3 - a(23): If a(5) < m1 Or a(5) > m2 Then GoTo 220 a(4) = 2 * s1 / 3 - a(24): If a(4) < m1 Or a(4) > m2 Then GoTo 220 a(3) = -s1 / 3 + a(26) + a(27): If a(3) < m1 Or a(3) > m2 Then GoTo 220 a(2) = 2 * s1 / 3 - a(26): If a(2) < m1 Or a(2) > m2 Then GoTo 220 a(1) = 2 * s1 / 3 - a(27): If a(1) < m1 Or a(1) > m2 Then GoTo 220 ' Exclude solutions with identical numbers GoSub 800: If fl1 = 0 Then GoTo 220 ' n9 = n9 + 1: GoSub 640 'Print results (selected numbers) ' n9 = n9 + 1: GoSub 650 'Print results (planes 1, 2, 3) n9 = n9 + 1: GoSub 660 'Print results (3d) 220 b(c(23)) = 0: c(23) = 0 230 Next j23 b(c(24)) = 0: c(24) = 0 240 Next j24 b(c(25)) = 0: c(25) = 0 250 b(c(26)) = 0: c(26) = 0 260 Next j26 b(c(27)) = 0: c(27) = 0 270 Next j27 t2 = Timer t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1) y = MsgBox(t10, 0, "Routine MgcCube3") End ' Print results (selected numbers) 640 For i1 = 1 To 27 Cells(n9, i1).Value = a(i1) Next i1 Return ' Print results (planes 1, 2 and 3) 650 n2 = n2 + 1 If n2 = 7 Then n2 = 1: k1 = k1 + 12: k2 = 1 Else If n9 > 1 Then k2 = k2 + 4 End If For i0 = 1 To 3 i3 = (i0 - 1) * 9 For i1 = 1 To 3 For i2 = 1 To 3 i3 = i3 + 1 Cells(k1 + i1 + (i0 - 1) * 4, k2 + i2).Value = a(i3) Next i2 Next i1 Cells(k1 + (i0 - 1) * 4, k2 + 1).Value = "Plane " + CStr(i0) Next i0 Return ' Print results (3d) 660 n2 = n2 + 1 If n2 = 4 Then n2 = 1: k1 = k1 + 16: k2 = 1 Else If n9 > 1 Then k2 = k2 + 16 End If For i0 = 1 To 3 i3 = (3 - i0) * 9 For i1 = 1 To 3 For i2 = 1 To 3 i3 = i3 + 1 Cells(k1 + 1 + (i1 - 1) * 2 + (i0 - 1) * 5, k2 + 5 + (i2 - 1) * 3 - (i1 - 1) * 2).Value = a(i3) Next i2 Next i1 Next i0 Return ' Exclude solutions with identical numbers 800 fl1 = 1 For j1 = 1 To 27 a2 = a(j1) For j2 = (1 + j1) To 27 If a2 = a(j2) Then fl1 = 0: GoTo 850 Next j2 Next j1 850 Return End Sub'
' Complete format first Cube
'Sub Macro1() y = MsgBox("Locked", vbCritical, "Routine Macro1, Borders") End For i0 = 0 To 2 For i1 = 3 To 8 Step 5 For i2 = 7 To 10 Step 3 Range(Cells(i1 + i0 * 2, i2 - i0 * 2), Cells(i1 + i0 * 2 + 4, i2 - i0 * 2 + 2)).Select: GoSub 250 Next i2 Next i1 Next i0 For i0 = 0 To 2 For i1 = 3 To 6 For i2 = 0 To 2 Range(Cells(i1 + i0 * 5, 9 - i1 + i2 * 3), Cells(i1 + i0 * 5, 9 - i1 + i2 * 3)).Select: GoSub 260 Next i2 Next i1 Next i0 Range("A1").Select End ' Border 250 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Color = -11489280 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Color = -11489280 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Color = -11489280 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Color = -11489280 .TintAndShade = 0 .Weight = xlThin End With Return ' Diagonal 260 With Selection.Borders(xlDiagonalUp) .LineStyle = xlContinuous .Color = -11489280 .TintAndShade = 0 .Weight = xlThin End With Return End Sub'
' Format all Cubes
'Sub Macro2() y = MsgBox("Locked", vbCritical, "Routine Macro2, Format all Cubes") End k1 = 2: k2 = 2: n2 = 1: n9 = 192 Range(Cells(2, 2), Cells(16, 12)).Select: Selection.Copy For i1 = 2 To n9 n2 = n2 + 1 If n2 = 4 Then n2 = 1: k1 = k1 + 16: k2 = 2 Else k2 = k2 + 16 End If Range(Cells(k1, k2), Cells(k1, k2)).Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next i1 Application.CutCopyMode = False Range("A1").Select End Sub'
' Make Bitmaps (MSO Diagonal Format not transferable to HTML)
'Sub Macro3() y = MsgBox("Locked", vbCritical, "Routine Macro3, Make Bitmaps") End k1 = 2: k2 = 2: n2 = 0: n9 = 192 sht1$ = "Klad1" For i1 = 1 To n9 n2 = n2 + 1 If n2 = 4 Then n2 = 1: k1 = k1 + 16: k2 = 2 Else If i1 > 1 Then k2 = k2 + 16 End If Worksheets(sht1$).Range(Cells(k1, k2), Cells(k1 + 15, k2 + 11)).CopyPicture xlScreen, xlBitmap Worksheets(sht1$).Paste Destination:=Worksheets(sht1$).Range(Cells(k1, k2), Cells(k1, k2)) Next i1 Range("A1").Select End Sub
|
|
About the Author |