Christmas Tree Mess

[kgkev]

I'm pretty new to VBA but thought I'd have a bash at an old puzzle I used to play on my first Amstrad.


Heres how the story goes.

My wife told me to put 2 christmas trees up in out living room. There isn't much space in our living room. I placed the red tree on the left and the blue tree on the right.

Run once on blank sheet to see how it looked.

Sub First_Build()
    Range("B7").Value = "1"
    Range("B8").Value = "22"
    Range("B9").Value = "333"
    Range("B10").Value = "4444"
    Range("B11").Value = "55555"
    Range("B12").Value = "666666"
    Range("B13").Value = "7777777"
    Range("B14").Value = "88888888"
    Range("B15").Value = "999999999"
    
    Range("B7:B15").Select
    Selection.Copy
    Range("F7").Select
    ActiveSheet.Paste
    Columns("B:F").Select
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Columns("B:F").ColumnWidth = 11.86
    Range("B7:B15").Font.ColorIndex = 3
    Range("F7:F15").Font.ColorIndex = 5
    Range("B16:F16").Interior.ColorIndex = 56
    Range("B16").Value = "X"
    Range("C16").Value = "X"
    Range("D16").Value = "X"
    Range("E16").Value = "X"
    Range("F16").Value = "X"
    Range("A3").Value = "Moves"
    Range("B3").Value = 0
End Sub

Doesn't that look nice...


Well I thought so. My wife had other ideas. She wanted the trees the other way round. Because of the size of the trees (9 feet tall each) and the weight of each section it was not possible to just slide them accross the room. I had to move one section at a time. But a larger section will break a smaller section so I could not place smaller sections onto larger sections.

place in Sheet1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If ActiveCell.Value = "X" Then
    Range("D2").Value = "Thats the Base"
    Exit Sub
End If

If ActiveCell.Offset(-1) <> "" Then
    Range("D2").Value = "Must Select the top Block"
    Exit Sub
End If
        
If ActiveCell <> "" Then
        ActiveCell.Cut
        Range("A1").Value = ActiveCell.Value
        Range("D2").Value = ""
        
Else
    If Application.CutCopyMode <> False Then
        If ActiveCell.Offset(1).Value = "" Then
            Range("D2").Value = "Must be placed on another block Or the Base"
            
            Exit Sub
        Else
            If Range("A1").Value >= ActiveCell.Offset(1).Value Then
                Range("D2").Value = "Must place on smaller block"
                
                Exit Sub
            Else
                ActiveSheet.Paste
                Application.CutCopyMode = False
                Range("B3").Value = Range("B3").Value + 1
            End If
        End If
    End If
    End If
End Sub

Click a tree section to select it - It must be at the top of a pile.
Select an empty cell to move it to the cell (must be top of a pile, blank or the bottom of the pile and smaller than the tree piece it is place onto)

You can mix the red and blue trees but they must finish all the same colour with the Red on the right and blue on the left.

The Black line shows my total floor space. you cannot use any cells outside this.

How many moves can you do it in.

Comments on my code welcome / appreciated.
What breaks it? What improvements can be made?

 

[Patience]

Well - I haven't played it all the way through yet - but I just wanted to say this is why I love this board.

That is so cool! Thank you!

 

[kgkev]

I found out that this is a "Tower of Hanoi"

and by adding a

Columns("E:E").Delete Shift:=xlToLeft

It is still possible to complete the puzzle - Only it might take all day.


Question
Word has a higlight text facility - Does excel have an equivelant?

 

[njimack]

Very impressive, although the first code could be tidied up a bit...

Sub First_Build()
    
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


    Range("B7") = "1"
    Range("B8") = "22"
    Range("B9") = "333"
    Range("B10") = "4444"
    Range("B11") = "55555"
    Range("B12") = "666666"
    Range("B13") = "7777777"
    Range("B14") = "88888888"
    Range("B15") = "999999999"
    
    Range("B7:B15").Copy Destination:=Range("F7")

    With Columns("B:F")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Columns("B:F").ColumnWidth = 11.86
    Range("B7:B15").Font.ColorIndex = 3
    Range("F7:F15").Font.ColorIndex = 5
    Range("B16:F16").Interior.ColorIndex = 56
    Range("B16:F16") = "X"
    Range("A3") = "Moves"
    Range("B3") = 0

With Application
    .EnableEvents = False
    .ScreenUpdating = True
End With

End Sub

 

[MorganO]

Add this code to the worksheet_change event (right at the beginning) to check and tell player that they have solved the puzzle:

'Check for puzzle completion
Dim rng As Range
Dim LeftRange As Double
Dim RightRange As Double
LeftRange = 0
RightRange = 0
For Each rng In Range("B7:B15")
LeftRange = LeftRange + rng.Font.Color
Next
For Each rng In Range("F7:F15")
RightRange = RightRange + rng.Font.Color
Next
If LeftRange / 9 = 16711680 And RightRange / 9 = 255 Then Range("D2").Value = ("You solved the Christmas Tree Mess!")

 

[mole999]

if you select the right tower, and colour red, and then the left and colour blue, it shows up as zero moves and the added "you solved the christmas tree mess" lol

as easier as peeling the stickies off a rubix cube

 

[MorganO]

Sorry, didn't have time to fully test!