nothing more than playing

in the same style
Code:
'Option NOT Explicit

Sub playit()
'Erik Van Geit
'only purpose: have fun while creating code

On Error GoTo stopit
Application.EnableCancelKey = xlErrorHandler

Set WB = Workbooks.Add
Set rng = Range("A1:Z26")
moveL = 1
moveT = 1
shW = 12

Application.ScreenUpdating = False

    With rng
    .NumberFormat = ";;;"
    .FormulaR1C1 = "=IF(AND(MOD(ROW(),5)=0,MOD(COLUMN(),5)=0),1,IF(AND(MOD(ROW(),4)=0,MOD(COLUMN(),4)=0),2,IF(AND(MOD(ROW(),3)=0,MOD(COLUMN(),3)=0),3,"""")))"
    .Value = .Value
    
        With .FormatConditions
        .Delete
            For i = 1 To 3
            .Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=i
            .Item(i).Interior.ColorIndex = i + 2
            Next i
        End With
    
    .Rows(.Rows.Count + 1 & ":" & Rows.Count).Hidden = True
    Columns.Hidden = True

        With .Columns.Resize(Rows.Count, .Columns.Count + 1)
        .Hidden = False
        .ColumnWidth = 2.6
        End With
        
    limitL = .Resize(1, .Columns.Count).Width - shW * 4 / 3
    limitT = .Resize(.Rows.Count, 1).Height - shW * 4 / 3
    End With
    
ActiveWindow.ScrollColumn = 1
Application.ScreenUpdating = True

    With ActiveSheet.Shapes.AddShape(msoShapeNoSymbol, limitL / 2, limitT / 2, shW, shW)
    .Fill.ForeColor.SchemeColor = 51
    .Line.ForeColor.SchemeColor = 53
    DoEvents
    Application.Wait Now + 1 / 86400
    L = .Left
    T = .Top
        Do
        L = L + moveL
        T = T + moveT
        
            If L < 0 Or L >= limitL Then moveL = -moveL * 1.01
            If T < 0 Or T >= limitT Then moveT = -moveT * 1.01
            
            With .TopLeftCell
                Select Case .Value
                Case 1
                moveL = -moveL
                moveT = -moveT
                .ClearContents
                Case 2
                moveT = -moveT
                .ClearContents
                Case 3
                moveL = -moveL
                .ClearContents
                End Select
            End With
        .Left = L
        .Top = T
        .Rotation = L * 6
        DoEvents
        Loop While Application.CountA(rng) > 0
    End With

stopit:
WB.Close False

End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Forum statistics

Threads
1,214,787
Messages
6,121,565
Members
449,038
Latest member
Guest1337

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top