spare time code

[erik.van.geit]

Hi,

don't know why I made this ... it just happened
could be nice to check out some functions and syntax

create new sheet or workbook
set cells to squares or run two extra lines: see code
paste code in sheet module (rightclick sheet - view code - paste)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Erik Van Geit
'070221
'use arrows to catch the black square
'you could use the mouse

Dim c As Range
Dim ud As Integer   'up down
Dim rl As Integer   'right left
Dim pg As Range     'playground

'set cells to squares or run these two lines
'Cells.ColumnWidth = 1.71
'Cells.RowHeight = 12.75

    'runnig next 3 lines each time could be avoided
    Set pg = ActiveWindow.VisibleRange
    Set pg = pg.Resize(pg.Rows.Count - 1, pg.Columns.Count - 1)
    ActiveSheet.ScrollArea = pg.Address
    
    Set c = pg.Find(1, lookat:=xlWhole)

    If c Is Nothing Then
    Set c = pg(1).Offset(Int(pg.Rows.Count * Rnd), Int(pg.Columns.Count * Rnd))
    c = 1
    End If

    Do
    ud = Choose(Int(Rnd * 5) + 1, -2, -1, 0, 1, 2)
    rl = Choose(Int(Rnd * 5) + 1, -2, -1, 0, 1, 2)
    If c.Row + ud <= 0 Then ud = 0
    If c.Column + rl <= 0 Then rl = 0
    Loop While Intersect(c.Offset(ud, rl), pg) Is Nothing
    
    With c
    .Interior.ColorIndex = xlNone
    .Value = ""
        With .Offset(ud, rl)
        .Interior.ColorIndex = 1
        .Value = 1
        End With
    End With
    
    If ActiveCell = 1 Then
    MsgBox "BRAVO", 64, "CATCH!!"
    c = ""
    c.Interior.ColorIndex = xlNone
    End If

End Sub

learn and enjoy
Erik

 

[Lewiy]

Hmmm, quite an amusing little game, equally addictive and frustrating. I'm sure this could be developed into something more elaborate, not sure what yet though!

 

[ExcelChampion]

Erik, That is really neat! Bravo, sir!

 

[erik.van.geit]

thanks, guys !

I'm getting lazy

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Erik Van Geit
'070221
'use arrows to catch the black square
'you could use the mouse

Dim ud As Integer   'up down
Dim rl As Integer   'right left

If busy = False Then loopit

'set cells to squares or run these two lines
'Cells.ColumnWidth = 1.71
'Cells.RowHeight = 12.75

    'runnig next 3 lines each time could be avoided
    Set pg = ActiveWindow.VisibleRange
    Set pg = pg.Resize(pg.Rows.Count - 1, pg.Columns.Count - 1)
    ActiveSheet.ScrollArea = pg.Address
    
    Set c = pg.Find(1, lookat:=xlWhole)

    If c Is Nothing Then
    Set c = pg(1).Offset(Int(pg.Rows.Count * Rnd), Int(pg.Columns.Count * Rnd))
    c = 1
    End If

    Do
    ud = Choose(Int(Rnd * 5) + 1, -2, -1, 0, 1, 2)
    rl = Choose(Int(Rnd * 5) + 1, -2, -1, 0, 1, 2)
    If c.Row + ud <= 0 Then ud = 0
    If c.Column + rl <= 0 Then rl = 0
    Loop While Intersect(c.Offset(ud, rl), pg) Is Nothing
    
    With c
    .Interior.ColorIndex = xlNone
    .Value = ""
        With .Offset(ud, rl)
        .Interior.ColorIndex = 1
        .Value = 1
        End With
    End With
    
    If ActiveCell = 1 Then
    MsgBox "BRAVO", 64, "CATCH!!"
        With c.Offset(ud, rl)
        .Interior.ColorIndex = xlNone
        .Value = ""
        End With
    busy = False
    End If
    
End Sub

normal module

Option Explicit

Public c As Range
Public pg As Range     'playground
Public busy As Boolean

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub loopit()
Dim i As Integer
Dim nextSel As Range

busy = True
Set pg = ActiveWindow.VisibleRange

On Error Resume Next
Set c = pg.Find(1, lookat:=xlWhole)
If Err Then Cells(7, Int(pg.Columns.Count / 2)).Select
On Error GoTo 0

On Error GoTo skip
    Do
        Sleep CLng(200)
        Set nextSel = Cells(ActiveCell.Row - Sgn(ActiveCell.Row - c.Row), ActiveCell.Column - Sgn(ActiveCell.Column - c.Column))
        If nextSel.Address <> ActiveCell.Address Then nextSel.Select Else nextSel.Offset(1, 1).Select
    Loop While ActiveCell <> 1 And busy = True
skip:
busy = False

End Sub

I really didn't look into the deepest details to clean up
don't know if it is possible

 

[erik.van.geit]

or

Option Explicit

Public c As Range
Public pg As Range     'playground
Public busy As Boolean

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub loopit()
Dim i As Integer
Dim txt As String
Dim nextSel As Range
Dim huh As String
Dim ro As Long
Dim co As Integer

txt = "    catch me if you can, you stupid activecell"
huh = "    WELL, LOST THE WAY ???"

busy = True
Set pg = ActiveWindow.VisibleRange

On Error Resume Next
Set c = pg.Find(1, lookat:=xlWhole)
If Err Then Cells(7, Int(pg.Columns.Count / 2)).Select

On Error GoTo skip
    Do
        Sleep CLng(200)
        
        If Rnd > 0.95 And i = 0 Then i = 1
        
        If i = 0 Then
        ro = Sgn(ActiveCell.Row - c.Row)
        co = Sgn(ActiveCell.Column - c.Column)
        Else
        i = i + 1
        ro = Sgn(ActiveCell.Row - c.Row) * -(Rnd > 0.7)
        co = Sgn(ActiveCell.Column - c.Column) * -(Rnd > 0.7)
        End If

        Set nextSel = Cells(ActiveCell.Row - ro, ActiveCell.Column - co)

        If Rnd > 0.9 Then i = 0

        If nextSel.Address <> ActiveCell.Address Then nextSel.Select Else nextSel.Offset(1, 1).Select
        
        txt = Right(txt, Len(txt) - 3) & Left(txt, 3)
        Application.StatusBar = IIf(i = 0, txt, huh)
        
    Loop While ActiveCell <> 1 And busy = True
skip:
busy = False
Application.StatusBar = False
End Sub

 

[Lewiy]

Erik, can you add something to this to work out the average number of moves (on the automated version) required to catch the black square? I'm just curious to know if this will be similar every time.

 

[erik.van.geit]

the code is "quite random", but to randomize even more you could add

Randomize Timer

I never looked in detail how to randomize "perfectly", there is probably some info in the helpfiles

to count the loops

Dim cnt as Integer

Do
cnt = cnt + 1
...
MsgBox cnt
End Sub