Geheugen vraag

[LucB]

Hallo Excellers,

In onderstaande code kunt u hopelijk zien waar ik mee bezig ben.
Tot nu toe gedaan:
6 cellen afgedekt met een rechthoek.(A1:C2)
Klikken op een cel maakt de inhoud zichtbaar.

Doel is:
Na 2x een klik op een willekeurige rechthoek moet het absolute verschil tussen de dan 2 zichtbare cellen 10 zijn.
Is dat niet het geval dan moet de 2 zichtbare cellen weer bedekt worden door hun bijbehorende rechthoek.

Graag Uw hulp om dit te verwezelijken.

Sub test()
    Dim MyCell As Range
    Dim n      As Long
    Dim p      As Long
    
    'In A1 is Rectangle 1, in B1 is Rectangle 2, in C1 is Rectangle 3.
    'In A2 is Rectangle 4, in B2 is Rectangle 5, in C2 is Rectangle 6.
    'de Rectangles en de cellen zijn 88x88 pixels en hebben de Macro's Rec1 t/m Rec6
    
    For n = 1 To 6
        ActiveSheet.Shapes("Rectangle " & n).Select
        Selection.ShapeRange.Fill.Visible = msoTrue
    Next n
    
    'In E5:E10  =ASELECT()
    'In F5:F10   A1,B1,C1,A2,B2,C2
    'In G5:G10   10,20,30,40,50,60.
    
    Range("E5:F10").Sort Key1:=Range("E5"), Order1:=xlAscending, Header:=xlGuess, _
                         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    For p = 1 To 6
        Set MyCell = ActiveSheet.Range(Range("F" & p + 4))
        MyCell.Value = Range("F" & p + 4).Offset(0, 1).Value
    Next p

    Set MyCell = Nothing
    Range("D1").Select
End Sub

Sub Rec1()
    ActiveSheet.Shapes("Rectangle 1").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("A1").Select
    
End Sub
Sub Rec2()
    ActiveSheet.Shapes("Rectangle 2").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("B1").Select
End Sub
Sub Rec3()
   ActiveSheet.Shapes("Rectangle 3").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("C1").Select
End Sub
Sub Rec4()
    ActiveSheet.Shapes("Rectangle 4").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("A2").Select
End Sub
Sub Rec5()
   ActiveSheet.Shapes("Rectangle 5").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("B2").Select
End Sub
Sub Rec6()
    ActiveSheet.Shapes("Rectangle 6").Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Range("C2").Select
End Sub

Met vr. groet,
Luc

 

[erik.van.geit]

Dag, Luc,

een paar vraagjes
Wil je dit project beperken to 6 cellen?
Misschien heeft het nu reeds belang te weten wat er zal gebeuren wanneer de cellen aan de voorwaarde beantwoorden en zichtbaar blijven? Het antwoord hierop zal de strategie bepalen om te "onthouden" wat de vorige "open" cell is, wanneer je de tweede rechthoek aanklikt.

het is niet nodig om voor elke rechthoek code te schrijven
link alle rechthoeken aan 1 enkele macro

Sub rectangle_click()
    Set ctrl = ActiveSheet.Shapes(Application.Caller)
    With ctrl
    .Fill.Visible = msoFalse
    .TopLeftCell.Select
    End With
End Sub

dit laatste maakt je project alvast overzichtelijker

beste groeten,
Erik

 

[LucB]

Dag Erik,
Fijn dat je mij wilt helpen.

Het is de bedoeling het project uit te breiden tot 32 cellen.
4 rijen bij 8 kolommen.

Je macro werkt perfect.

Ben zeer benieuwd naar de voortzetting.

Voor nu hartelijkdank

Groet,
Luc

 

[erik.van.geit]

OK, eerste stap geslaagd dus
er was nog een vraag die me belangrijk leek, alvorens iets yut te werken

Misschien heeft het nu reeds belang te weten wat er zal gebeuren wanneer de cellen aan de voorwaarde beantwoorden en zichtbaar blijven? Het antwoord hierop zal de strategie bepalen om te "onthouden" wat de vorige "open" cell is, wanneer je de tweede rechthoek aanklikt.

en ook:
is dit een spelletje ?
kwestie van me wat in te leven ... werkt vlotter, want meer inspiratie
vrijdag zal je me wellicht meer online vinden dan vandaag

 

[LucB]

Goedemorgen Erik,

Het doel is dat alle cellen paarsgewijs zichtbaar worden.

Het moet een speels rekenprogramma worden voor m'n kleinkinderen in de leeftijd van 5-7jaar. Het is een combinatie van memorie en sommetjes maken.

Hopelijk is dit voldoende voor de inspiratie.

Tot ziens en een fijne dag.

Groet,
Luc

 

[erik.van.geit]

Hello, Luc,
this will get you started
ach, nee, in't Nederlandisch here

Option Explicit

'http://support.microsoft.com/?kbid=213777
'This function declaration must be entered onto a single line.
Private Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    
Public mem As Shape
Const difference As Integer = 10

Sub PlaySound()
    If Application.CanPlaySounds Then
        'Substitute the path and filename of the sound you want to play
        Call sndPlaySound32("c:\windows\media\chimes.wav", 0)
    End If
End Sub

Sub initialize()
    Dim MyCell As Range
    Dim n      As Long
    Dim p      As Long
    
    For n = 1 To 6
        ActiveSheet.Shapes("Rectangle " & n).Select
        Selection.ShapeRange.Fill.Visible = msoTrue
    Next n
    
    Range("E5:F10").Sort Key1:=Range("E5"), Order1:=xlAscending, Header:=xlGuess, _
                         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

    For p = 1 To 6
        Set MyCell = ActiveSheet.Range(Range("F" & p + 4))
        MyCell.Value = Range("F" & p + 4).Offset(0, 1).Value
    Next p

    Set MyCell = Nothing
    Set mem = Nothing
End Sub

Sub rectangle_click()
Dim ctrl As Shape

    Set ctrl = ActiveSheet.Shapes(Application.Caller)
    With ctrl
    .Fill.Visible = msoFalse    'Not .Fill.Visible
    .TopLeftCell.Select
        If Not mem Is Nothing Then
            If Abs(.TopLeftCell - mem.TopLeftCell) = difference Then
            PlaySound
            Else
            Application.Wait Now + 3 / 60 / 60 / 24
            .Fill.Visible = msoTrue
            mem.Fill.Visible = msoTrue
            End If
        Set mem = Nothing
        Else
        Set mem = ctrl
        End If
    End With
End Sub

als de verschillen telkens 10 moeten zijn kan het gebeuren dat er vakken niet "uitgespeeld" kunnen worden
had je daar al aan gedacht ?
20-30
40-50
10-60 ???

beste groeten,
Erik

 

[LucB]

Hallo Erik,

Het is weer geweldig.
Het draait als een zonnetje.
Ook het geluidje is leuk.

ik ga nu de cellen uitbreiden tot 32.

Heel hartelijk bedankt.
Weer veel geleerd, mn Application.Caller.

Nog een fijne dag.

Groet,
Luc

 

[erik.van.geit]

Luc,
you're welcome
maar hoe los je dit op ?

als de verschillen telkens 10 moeten zijn kan het gebeuren dat er vakken niet "uitgespeeld" kunnen worden
had je daar al aan gedacht ?
20-30
40-50
10-60 ???

 

[LucB]

Erik,

Ik doe het zo:
Die weet uit te spelen krijgt een bonus.
Zo niet,dan pech gehad.
Its all in the game.

(dat is de oplossing als je geen oplossing weet)

De junioren hebben er mee gespeeld.
Ze vonden het gaaf en best pittig.

Nogmaals dank.

Groet,
Luc

 

[erik.van.geit]

Die weet uit te spelen krijgt een bonus.
Zo niet,dan pech gehad.
Its all in the game.

da's niet eerlijk !!!
misschien wel, maar niet voor mij

Een oplossing is om geen mogelijkheden toe te laten die niet uitspeelbaar zijn.
0
10
11
21
32
42