# For Fun and Learning Project



## Legacy 98055 (Oct 15, 2006)

My son, who is in the 4th grade, was solving these puzzles.  They are easy enough to do by hand, but I wanted to try an Excel and/or code approach.  I know very little about what kind of algorithm one might develop to efficiently solve this and am very curious to see what a good solution would end up looking like.  If anybody is really bored or considers this at all challenging, please post your solution here for the whole world to see.  

BTW.  You are solving for each letter.  What does "A" equal, and so on..



 Tj's Enrichment Packet.zip


----------



## SydneyGeek (Oct 17, 2006)

Tom, 

Here's a punt at the logic I used to get started...

1. Work out all the possible factors of 30, 40 and 48. 
30 can be {1,5,6} or {2,3,5}
40 can be {1,5,8} or {2,4,5}
48 can be {1,6,8} or {2,3,8} or {2,4,6}

2. From the above, we don't need to consider 7 or 9.

3. We can also assign 2 numbers immediately: F = 0 because the only multiplication that involves it is equal to 0, and B = 5 because (i) 5 is part of the solution matrix, (ii) B is common to both calculations that have 5 as a factor, and (iii) both 30 and 40 _must_ have a 5.

4. That leaves {1,2,3,4,6,8} to be assigned to {A,C,D,E,G,H}. We can build some restrictions for a few of the letters:
(i) C cannot be 4, because it is the junction between 30 and 48, and 4 is not a factor of 30
(ii) From the original conditions, and given that B =5, we have C + E + G =9. That leaves 8 out of this series, so either D or H must be 8. 

5. Let's see how far we get with H = 8. 
(i) G = 1 
(ii) C + E = 8, so C can be 2 or 6. If C = 6, A must be 1 which can't happen because G = 1. So, C = 2 and A = 3. 
(iii) E = 6, making D = 4.

So, solution that tries to minimise the options to test. Would that be a good starting point for a programming approach?

Denis


----------



## SydneyGeek (Oct 17, 2006)

Had a go with setting up a Solver solution. I was able to get a result if the values didn't have to be unique; as soon as I added that constraint, Solver spat the dummy. 

5 separate runs:

```
A	1	2	2	2	2
B	5	5	5	5	5
C	6	3	3	3	3
D	4	8	4	4	8
E	2	2	4	4	2
F	0	0	0	0	0
G	1	4	2	2	4
H	8	2	4	4	2
```

It looks like the approach might still be: 
1. Assign definite starting values if possible
2. Use the B+C+E+G calculation to limit the options
3. Run through all the possible starting positions of a nominated variable, rejecting any solutions that violate the "unique" condition. 

Denis


----------



## Andrew Fergus (Oct 17, 2006)

Hi Tom and Denis

I think I have solved this one but I did make some assumptions.  The biggest assumption was that there wouldn't be two products with a value of zero.  I also stored a number of values within the spreadsheet to assist with the process.  Using the same layout per your spreadsheet, with the values in the same cell positions, try the following code :


```
Option Explicit

'************************************************************************
'
'This code was developed by Andrew Fergus on 18 October 2006
'in response to this question on MrExcel:
'http://www.mrexcel.com/board2/viewtopic.php?t=238026
'
'************************************************************************

Public Sub SolvePuzzle()

On Error Resume Next
'Used to capture instances where the vlookup finds nothing

Dim Answers(8) As Integer, _
    OuterLoop As Integer, _
    TempLoop As Integer, _
    Loop2 As Integer, _
    Loop3 As Integer, _
    LoopLimit As Integer, _
    Finished(4) As Boolean, _
    Values(10, 1) As Integer, _
    Outcome(4) As Integer, _
    TempVar1 As Integer, _
    TempVar2 As Double
    
'Values variable:
'   holds the values 0 through 9
'   dimension 0 is used to hold the value
'   dimension 1 is used to hold the used value (where 1 = used)

'Initialise variables
Outcome(0) = Range("C3").Value
Outcome(1) = Range("C2").Value
Outcome(2) = Range("D3").Value
Outcome(3) = Range("C4").Value
Outcome(4) = Range("B3").Value
Range("G1") = "BDFH Possibles"
Range("L1") = "HAB Factors"
Range("N1") = "BCD Factors"
Range("P1") = "DEF Factors"
Range("R1") = "FGH Factors"
TempVar2 = Cells(Rows.Count, "G").End(xlUp).Row
If TempVar2 > 1 Then
    Range("G2:R" & TempVar2).ClearContents
End If

'Set values to zero
For TempLoop = 0 To 10
    Values(TempLoop, 0) = TempLoop
    Values(TempLoop, 1) = 0
Next
'Set answers to zero
For TempLoop = 0 To 8
    Answers(TempLoop) = 0
Next
'Initialise finished variables
For TempLoop = 0 To 4
    Finished(TempLoop) = False
Next

If Outcome(0) = 6 Then
    'BDFH is the minima (0,1,2,3)
    Range("G2") = 0
    Range("H2") = 1
    Range("I2") = 2
    Range("J2") = 3
    LoopLimit = 2
ElseIf Outcome(0) = 30 Then
    'BDFH is the maxima (6,7,8,9)
    Range("G2") = 6
    Range("H2") = 7
    Range("I2") = 8
    Range("J2") = 9
    LoopLimit = 2
Else
    'Find the possible combinations of values for positions BDFH
    GetBDFH (Outcome(0))
    LoopLimit = Cells(Rows.Count, "G").End(xlUp).Row
End If

'Get the factors for the other 4 outcomes
Call GetFactors(Outcome(1), "L")
Call GetFactors(Outcome(2), "N")
Call GetFactors(Outcome(3), "P")
Call GetFactors(Outcome(4), "R")

'rowcount for debugging output
'TempVar1 = 2

For OuterLoop = 2 To LoopLimit
'Loop through all combinations of BDFH
    'Get the starting values around Outcome(0)
    Answers(2) = Range("G" & OuterLoop).Value
    Answers(4) = Range("H" & OuterLoop).Value
    Answers(6) = Range("I" & OuterLoop).Value
    Answers(8) = Range("J" & OuterLoop).Value
    For Loop2 = 1 To 4
    'Loop through the 4 corner values (around BDFH)
        If Loop2 > 1 Then
        'Rotate the values around Outcome(0)
            Answers(0) = Answers(8)
            For TempLoop = 8 To 2 Step -2
                Answers(TempLoop) = Answers(TempLoop - 2)
            Next
        End If
        For Loop3 = 1 To 6
            If Loop3 > 1 Then
            'Rotate the last 3 values around Outcome(0), but fix the lowest value
                Select Case Loop2
                    Case 1
                        If Loop3 Mod 2 = 0 Then
                        'Mod and case used to decide which pair of digits to swap
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        End If
                    Case 2
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case 3
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case Else
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                End Select
            End If
            
            'Reset variables
            'Probably not 100% necessary / efficient but effective
            For TempLoop = 0 To 9
                Values(TempLoop, 1) = 0
            Next
            For TempLoop = 1 To 4
                Values(Answers(TempLoop * 2), 1) = 1
            Next
            Answers(1) = 0
            Answers(3) = 0
            Answers(5) = 0
            Answers(7) = 0
            For TempLoop = 1 To 4
                Finished(TempLoop) = False
            Next
            
            'Set the 4 product values
            
            'Check the first outcome
            If Outcome(1) = 0 Then
                TempVar2 = 0
            Else
                'Calculate the factor
                TempVar2 = Outcome(1) / (Answers(2) * Answers(8))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("L2:L11"), 1, False) <> TempVar2 Then
                'Can't find factor in the pre-set list of factors
                Finished(1) = False
            Else
                If Values(TempVar2, 1) = 0 Then
                'This value has not been used yet
                    Values(TempVar2, 1) = 1
                    Answers(1) = TempVar2
                    Finished(1) = True
                Else
                'This value has already been used
                    Finished(1) = False
                End If
            End If
            
            'Check 2nd outcome
            If Outcome(2) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(2) / (Answers(2) * Answers(4))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("N2:N11"), 1, False) <> TempVar2 Then
                Finished(2) = False
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(3) = TempVar2
                    Finished(2) = True
                Else
                    Finished(2) = False
                End If
            End If
            
            'Check 3rd outcome
            If Outcome(3) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(3) / (Answers(4) * Answers(6))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("P2:P11"), 1, False) <> TempVar2 Then
                Finished(3) = False
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(5) = TempVar2
                    Finished(3) = True
                Else
                    Finished(3) = False
                End If
            End If
            
            'Check 4th outcome
            If Outcome(4) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(4) / (Answers(6) * Answers(8))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("R2:R11"), 1, False) <> TempVar2 Then
                Finished(4) = False
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(7) = TempVar2
                    Finished(4) = True
                Else
                    Finished(4) = False
                End If
            End If
            
            'Used for debugging
            'Range("AA" & TempVar1).Value = Answers(1)
            'Range("AB" & TempVar1).Value = Answers(2)
            'Range("AC" & TempVar1).Value = Answers(3)
            'Range("AD" & TempVar1).Value = Answers(4)
            'Range("AE" & TempVar1).Value = Answers(5)
            'Range("AF" & TempVar1).Value = Answers(6)
            'Range("AG" & TempVar1).Value = Answers(7)
            'Range("AH" & TempVar1).Value = Answers(8)
            
            If Finished(1) = True And Finished(2) = True And Finished(3) = True And Finished(4) = True Then
                GoTo JumpOut        'Yes I know this is sloppy but hey it works!
            End If
            'Used for the debugging row count
            'TempVar1 = TempVar1 + 1
        Next
    Next
Next

'If the code has ended up here it has looped through every combination
MsgBox "Answer not found"
Exit Sub

JumpOut:

'Display the answers
Range("C1").Value = Answers(1)
Range("D2").Value = Answers(2)
Range("E3").Value = Answers(3)
Range("D4").Value = Answers(4)
Range("C5").Value = Answers(5)
Range("B4").Value = Answers(6)
Range("A3").Value = Answers(7)
Range("B2").Value = Answers(8)

MsgBox "Finished"

End Sub

Private Sub GetBDFH(Outcome As Integer)

Dim RowCounter As Integer, _
    Loop1 As Integer, _
    Loop2 As Integer, _
    Loop3 As Integer, _
    Loop4 As Integer, _
    MyValues(4) As Integer

RowCounter = 2

For Loop1 = 1 To 4
    MyValues(Loop1) = Loop1
Next

For Loop1 = 0 To 5
    For Loop2 = 1 To 6
        For Loop3 = 2 To 7
            For Loop4 = 3 To 9
                If Loop4 < MyValues(4) Then
                    'Do Nothing
                Else
                    MyValues(4) = Loop4
                    If MyValues(1) + MyValues(2) + MyValues(3) + MyValues(4) = Outcome Then
                        Range("G" & RowCounter) = MyValues(1)
                        Range("H" & RowCounter) = MyValues(2)
                        Range("I" & RowCounter) = MyValues(3)
                        Range("J" & RowCounter) = MyValues(4)
                        RowCounter = RowCounter + 1
                    End If
                End If
            Next
            MyValues(3) = MyValues(3) + 1
            MyValues(4) = MyValues(3) + 1
        Next
        MyValues(2) = MyValues(2) + 1
        MyValues(3) = MyValues(2) + 1
        MyValues(4) = MyValues(3) + 1
    Next
    MyValues(1) = MyValues(1) + 1
    MyValues(2) = MyValues(1) + 1
    MyValues(3) = MyValues(2) + 1
    MyValues(4) = MyValues(3) + 1
Next

End Sub

Private Sub GetFactors(TestNum As Integer, ColPos As String)

Dim LoopCount As Integer, RowCounter As Integer

If TestNum = 0 Then
    For LoopCount = 0 To 9
        Range(ColPos & (2 + LoopCount)).Value = LoopCount
    Next
Else
    RowCounter = 2
    For LoopCount = 1 To 9
        If TestNum Mod LoopCount = 0 Then
            Range(ColPos & RowCounter).Value = LoopCount
            RowCounter = RowCounter + 1
        End If
    Next
End If

End Sub
```

The code could probably be tidied up but after a relatively quiet day, maybe I should actually do some work! (given it's almost 5pm here)

Cheers, Andrew

P.S.  I also changed the A-H notation where A starts at cell C1 and then goes in clockwise direction through B at D2 and so on.


----------



## Andrew Fergus (Oct 18, 2006)

For such an easy puzzle, it was pretty complex to code.  To clarify the approach adopted :

1)  Work out the combination of values that add to the central number.

In this example there were only 5 possible combinations that could give the number 14.  These combinations are stored within the spreadsheet for ease of access later on.  Major assumption : a zero is not in one of these four positions (this could be factored into the code but I opted to leave it out at the moment).

2)  Work out all of the possible factors for the 4 product values.

These will be used later as part of lookup routine so they are stored within the spreadsheet.  The maximum number of factors for any one product is 10 (ie where the product = 0).

3)  Using shuffling techniques (that I just made that up) hold one of the 4 middle values stationery and swap all of the others around.  Repeat for the held number in all 4 possible positions.  Test each permutation per step 4 below.

This puts all possible combinations of 14 into the 4 different positions (mine was BDFH, the original example was BCEG).  In this case there were 5 combinations * 4 positions * 6 permutations = 120 permutations to test.  For a median value like 18, there are 11 possible combinations and 11 * 4 * 6 = 264 possible solutions to test.  Not bad considering Fact(9) = 362k if you tried a pure brute force method.

4)  Test each permutation / possible solution as follows : given we have two of the three values required for the product, calculate the third value to see what the missing factor is.  If this factor is in the list of possible factors, then that is good and we need to test the other 3 missing numbers.  If not then this 'solution' is discarded and we try another.


The code runs pretty quickly (my tests are about 3 seconds on solutions designed to push my algorithms to their end values) but it could be faster.

Andrew


----------



## Andrew Fergus (Oct 18, 2006)

This version runs a little quicker (sub 2 seconds) given the introduction of a couple of goto statements (yes I know...) and I've tweaked a couple of the loops.

If I copy this code into your spreadsheet Tom it doesn't find the answer, but if I type the values into my own spreadsheet it does!?!


```
Option Explicit

'************************************************************************
'
'This code was developed by Andrew Fergus on 18 October 2006
'in response to this question on MrExcel:
'http://www.mrexcel.com/board2/viewtopic.php?t=238026
'
'************************************************************************

Public Sub SolvePuzzle()

On Error Resume Next
'Used to capture instances where the vlookup finds nothing

Dim Answers(8) As Integer, _
    OuterLoop As Integer, _
    TempLoop As Integer, _
    Loop2 As Integer, _
    Loop3 As Integer, _
    LoopLimit As Integer, _
    Finished(4) As Boolean, _
    Values(10, 1) As Integer, _
    Outcome(4) As Integer, _
    TempVar1 As Integer, _
    TempVar2 As Double
    
'Values variable:
'   holds the values 0 through 9
'   dimension 0 is used to hold the value
'   dimension 1 is used to hold the used value (where 1 = used)

'Initialise variables
Outcome(0) = Range("C3").Value
Outcome(1) = Range("C2").Value
Outcome(2) = Range("D3").Value
Outcome(3) = Range("C4").Value
Outcome(4) = Range("B3").Value
Range("G1") = "BDFH Possibles"
Range("L1") = "HAB Factors"
Range("N1") = "BCD Factors"
Range("P1") = "DEF Factors"
Range("R1") = "FGH Factors"
TempVar2 = Cells(Rows.Count, "G").End(xlUp).Row
If TempVar2 > 1 Then
    Range("G2:R" & TempVar2).ClearContents
End If

'Set the values
For TempLoop = 0 To 10
    Values(TempLoop, 0) = TempLoop
    Values(TempLoop, 1) = 0
Next
'Set initial answers to zero
For TempLoop = 0 To 8
    Answers(TempLoop) = 0
Next

If Outcome(0) = 6 Then
    'BDFH is the minima (0,1,2,3)
    Range("G2") = 0
    Range("H2") = 1
    Range("I2") = 2
    Range("J2") = 3
    LoopLimit = 2
ElseIf Outcome(0) = 30 Then
    'BDFH is the maxima (6,7,8,9)
    Range("G2") = 6
    Range("H2") = 7
    Range("I2") = 8
    Range("J2") = 9
    LoopLimit = 2
Else
    'Find the possible combinations of values for positions BDFH
    GetBDFH (Outcome(0))
    LoopLimit = Cells(Rows.Count, "G").End(xlUp).Row
End If

'Get the factors for the other 4 outcomes
Call GetFactors(Outcome(1), "L")
Call GetFactors(Outcome(2), "N")
Call GetFactors(Outcome(3), "P")
Call GetFactors(Outcome(4), "R")

'rowcount for debugging output
'TempVar1 = 2

For OuterLoop = 2 To LoopLimit
'Loop through all combinations of BDFH
    'Get the starting values around Outcome(0)
    Answers(2) = Range("G" & OuterLoop).Value
    Answers(4) = Range("H" & OuterLoop).Value
    Answers(6) = Range("I" & OuterLoop).Value
    Answers(8) = Range("J" & OuterLoop).Value
    For Loop2 = 1 To 4
    'Loop through the 4 corner values (around BDFH)
        If Loop2 > 1 Then
        'Rotate the values around Outcome(0)
            Answers(0) = Answers(8)
            For TempLoop = 8 To 2 Step -2
                Answers(TempLoop) = Answers(TempLoop - 2)
            Next
        End If
        For Loop3 = 1 To 6
            If Loop3 > 1 Then
            'Rotate the last 3 values around Outcome(0), but fix the lowest value
                Select Case Loop2
                    Case 1
                        If Loop3 Mod 2 = 0 Then
                        'Mod and case used to decide which pair of digits to swap
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        End If
                    Case 2
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case 3
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case Else
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                End Select
            End If
            
            'Reset variables
            For TempLoop = 0 To 9
                Values(TempLoop, 1) = 0
            Next
            For TempLoop = 1 To 4
                Values(Answers(TempLoop * 2), 1) = 1
            Next
            Answers(1) = 0
            Answers(3) = 0
            Answers(5) = 0
            Answers(7) = 0
            For TempLoop = 1 To 4
                Finished(TempLoop) = False
            Next
            
            'Set the 4 product values
            
            'Check the first outcome
            If Outcome(1) = 0 Then
                TempVar2 = 0
            Else
                'Calculate the factor
                TempVar2 = Outcome(1) / (Answers(2) * Answers(8))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("L2:L11"), 1, False) <> TempVar2 Then
                'Can't find factor in the pre-set list of factors
                Finished(1) = False
                'No point testing the other 3 products
                GoTo Skip_To_Here
            Else
                If Values(TempVar2, 1) = 0 Then
                'This value has not been used yet
                    Values(TempVar2, 1) = 1
                    Answers(1) = TempVar2
                    Finished(1) = True
                Else
                'This value has already been used
                    Finished(1) = False
                    GoTo Skip_To_Here
                End If
            End If
            
            'Check 2nd outcome
            If Outcome(2) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(2) / (Answers(2) * Answers(4))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("N2:N11"), 1, False) <> TempVar2 Then
                Finished(2) = False
                GoTo Skip_To_Here
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(3) = TempVar2
                    Finished(2) = True
                Else
                    Finished(2) = False
                    GoTo Skip_To_Here
                End If
            End If
            
            'Check 3rd outcome
            If Outcome(3) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(3) / (Answers(4) * Answers(6))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("P2:P11"), 1, False) <> TempVar2 Then
                Finished(3) = False
                GoTo Skip_To_Here
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(5) = TempVar2
                    Finished(3) = True
                Else
                    Finished(3) = False
                    GoTo Skip_To_Here
                End If
            End If
            
            'Check 4th outcome
            If Outcome(4) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(4) / (Answers(6) * Answers(8))
            End If
            If WorksheetFunction.VLookup(TempVar2, Worksheets("Sheet1").Range("R2:R11"), 1, False) <> TempVar2 Then
                Finished(4) = False
            Else
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(7) = TempVar2
                    Finished(4) = True
                Else
                    Finished(4) = False
                End If
            End If
            
Skip_To_Here:
            
            'Used for debugging
            'Range("AA" & TempVar1).Value = Answers(1)
            'Range("AB" & TempVar1).Value = Answers(2)
            'Range("AC" & TempVar1).Value = Answers(3)
            'Range("AD" & TempVar1).Value = Answers(4)
            'Range("AE" & TempVar1).Value = Answers(5)
            'Range("AF" & TempVar1).Value = Answers(6)
            'Range("AG" & TempVar1).Value = Answers(7)
            'Range("AH" & TempVar1).Value = Answers(8)
            
            If Finished(1) = True And Finished(2) = True And Finished(3) = True And Finished(4) = True Then
                GoTo JumpOut        'Yes I know this is sloppy but hey it works!
            End If
            'Used for the debugging row count
            'TempVar1 = TempVar1 + 1
        Next
    Next
Next

'If the code has ended up here it has looped through every combination
MsgBox "Answer not found"
Range("C1").Value = "?"
Range("D2").Value = "?"
Range("E3").Value = "?"
Range("D4").Value = "?"
Range("C5").Value = "?"
Range("B4").Value = "?"
Range("A3").Value = "?"
Range("B2").Value = "?"
Exit Sub

'If a combination is found then the loop jumps out to here
JumpOut:
'Display the answers
Range("C1").Value = Answers(1)
Range("D2").Value = Answers(2)
Range("E3").Value = Answers(3)
Range("D4").Value = Answers(4)
Range("C5").Value = Answers(5)
Range("B4").Value = Answers(6)
Range("A3").Value = Answers(7)
Range("B2").Value = Answers(8)

MsgBox "Finished"

End Sub

Private Sub GetBDFH(Outcome As Integer)

Dim RowCounter As Integer, _
    GLoop1 As Integer, _
    GLoop2 As Integer, _
    GLoop3 As Integer, _
    GLoop4 As Integer

RowCounter = 2

For GLoop1 = 1 To 5
    For GLoop2 = (GLoop1 + 1) To 6
        For GLoop3 = (GLoop2 + 1) To 7
                For GLoop4 = (GLoop3 + 1) To 9
                    If GLoop1 + GLoop2 + GLoop3 + GLoop4 = Outcome Then
                        Range("G" & RowCounter) = GLoop1
                        Range("H" & RowCounter) = GLoop2
                        Range("I" & RowCounter) = GLoop3
                        Range("J" & RowCounter) = GLoop4
                        RowCounter = RowCounter + 1
                    End If
            Next
        Next
    Next
Next

End Sub

Private Sub GetFactors(TestNum As Integer, ColPos As String)

Dim LoopCount As Integer, RowCounter As Integer

If TestNum = 0 Then
    For LoopCount = 0 To 9
        Range(ColPos & (2 + LoopCount)).Value = LoopCount
    Next
Else
    RowCounter = 2
    For LoopCount = 1 To 9
        If TestNum Mod LoopCount = 0 Then
            Range(ColPos & RowCounter).Value = LoopCount
            RowCounter = RowCounter + 1
        End If
    Next
End If

End Sub
```
A


----------



## Legacy 98055 (Oct 18, 2006)

Thanks Andrew and Denis.  Andrew, your solution worked very fast for me on a somewhat older computer and solved the problem pretty much instantaneously.  Because your code is complicated (too me anyway),  I appreciate the explanation.  I tried your code on another puzzle that I made up in random.  It worked sometimes and did not at others.  I looked for module level variables or some other cause for this.  When you have time, please comment on the attached...

Denis.  Thanks for your good comments as well.  The reason why this little problem aroused my curiosty is because I want to gain some more problem solving skills.  Will be starting college in a few weeks and am gung ho for learning AMAP.    Thanks for the input...



 Tj's Enrichment Packet - Andrew.zip


----------



## Andrew Fergus (Oct 18, 2006)

Hi Tom

When I run the code in your spreadsheets the vlookup line fails and it can't find the factor and accordingly can't find the solution (even if it is trying to look up a value that is in the list!).  However, when I run this over my own spreadsheets, it works.  Is this a floating point error?  The vlookup part of the code did cause a number of problems and I'm wondering if there is a better way of coding that - maybe working out the missing factor and then seeing if that is a geniune factor via another subroutine - it will slow the code but will prevent these errors.  Hmmm - I might have to give that a go.

Cheers, Andrew


----------



## SydneyGeek (Oct 18, 2006)

Hi Andrew, 


> I think I have solved this one but I did make some assumptions. The biggest assumption was that there wouldn't be two products with a value of zero.


That's a fair enough assumption. If there's a double 0, that means you have a 0 at one of the vertices of {B,D,F,H} (your layout) and 2 unknowns with 4 possible numbers. That gives 12 possible solutions. 

A suggestion for reducing the #of possible starting positions: as you said, 18 can be the sum of 11 combinations of 4 numbers. Some of those will contain numbers that are NOT factors of the 3-way multiples, so they can be removed before you start looping. 

Food for thought...

Denis


----------



## SydneyGeek (Oct 19, 2006)

Andrew, I did some playing with your solution. I reckon there's a couple of simple refinements that you can make. 

1. If one of the outcomes is 0, don't factor it. 
2. In columns T and U, build values 0 to 9 (T2:T11) and a count of all factors found (U2:U11)
3. Then use this list to remove any BDFH Possibles containing a value that is not a factor. 

The following code does items 2 and 3:

```
Sub TrimOptions()
Dim vOut() As Variant
Dim c As Range

vOut = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

Range("T2:T11") = WorksheetFunction.Transpose(vOut)
Range("U2:U11").FormulaR1C1 = "=COUNTIF(R2C12:R11C18,RC[-1])"

For Each c In Range("G2:J" & Range("J65536").End(xlUp).Row)
    If Not IsEmpty(c) Then
        If WorksheetFunction.VLookup(c.Value, Range("T2:U11"), 2, False) = 0 Then
            Cells(c.Row, 7).Resize(1, 4).Delete Shift:=xlShiftUp
        End If
    End If
Next c
End Sub
```
You would call it once the items are factored and the possibles list is built, but before running the outer loops. This may eliminate the crash that Tom found, without you needing to check the VLOOKUP output all the time. 

Denis


----------



## Andrew Fergus (Oct 23, 2006)

Hi Denis

Nice suggestion - that eliminates records from the outer loop which should speed things up.  I've implemented your suggestions but, in testing I've found that in some instances the countif doesn't recalculate fast enough and the wrong rows are deleted from the BDFH possibilities.  I also introduced a pause into your process (which defeats the speed purpose) but it still won't recalculate in time.  I'm starting the think the code needs an entire re-write because it was designed to use the vlookup functions to find the factors (your code doesn't remove the requirement for the vlookup), and that is the part that occasionally fails for some inexplicable reason......

Cheers, Andrew


----------



## SydneyGeek (Oct 23, 2006)

Hi Andrew, 

I've been having a bit of a play too. My aim is to try the following:

1. Build a list of possibles, removing any rows with non-factors (as per my earlier suggestion)
2. Create list of all the factor triplets for the 3 points with a non-zero product. 
This code does that (borrowed some of your terminology for the Outcomes array):

```
Sub SolveGrid()
    Dim Outcomes(0 To 4) As Variant
    Dim Answers(1 To 8) As Variant
    Dim i As Integer, j As Integer, l As Integer, x As Integer, y As Integer, z As Integer
    Dim m As Long, n As Long, p As Long
    
    'initialise arrays
    For z = 1 To 8
        Answers(z) = 0
    Next z
    Outcomes(0) = Range("C3").Value
    Outcomes(1) = Range("C2").Value
    Outcomes(2) = Range("D3").Value
    Outcomes(3) = Range("C4").Value
    Outcomes(4) = Range("B3").Value
    
    'set up reference values in worksheet
    PrepareStartVals
    Factors
    BDFH_Possibles
End Sub
Sub PrepareStartVals()
    Range("G:AG").ClearContents
    Range("G1").Value = "BDFH Possibles"
    Range("L1") = "ABH Factors"
    Range("P1") = "BCD Factors"
    Range("T1") = "DEF Factors"
    Range("X1") = "FGH Factors"
    
End Sub

Sub BDFH_Possibles()
    Dim i As Integer, j As Integer, k As Integer, l As Integer, z As Integer
    Dim iSum As Integer
    Dim m As Long, x As Long
    Dim c As Range
    Dim vArray() As Variant
    
    x = 30 'arbitrary, but overkill for the # of possible options
    iSum = Range("C3").Value
    ReDim vArray(1 To x, 1 To 4)
    m = 1
    For i = 1 To 6
        For j = 2 To 7
            For k = 3 To 8
                For l = 4 To 9
                    If j > i And k > j And l > k Then
                        z = i + j + k + l
                        If z = iSum Then
                            vArray(m, 1) = i
                            vArray(m, 2) = j
                            vArray(m, 3) = k
                            vArray(m, 4) = l
                            m = m + 1
                        End If
                    End If
                Next l
            Next k
        Next j
    Next i
    Range("G2").Resize(x, 4) = vArray
    'remove any rows containing disallowed factors
    For Each c In Range("G2:J" & Range("J65536").End(xlUp).Row)
        If WorksheetFunction.CountIf(Range("L2:Z10"), c.Value) = 0 Then _
           Cells(c.Row, 7).Resize(1, 4).Delete
    Next c
    
End Sub

Sub Factors()
    Dim vProducts(1 To 4) As Variant 'holds the 4 3-way products
    Dim vArray(1 To 10, 1 To 3) As Variant
    Dim i As Integer, j As Integer, k As Integer, l As Integer
    Dim z As Integer
    Dim m As Long
    
    vProducts(1) = Range("C2").Value
    vProducts(2) = Range("D3").Value
    vProducts(3) = Range("C4").Value
    vProducts(4) = Range("B3").Value
    
    For l = 1 To 4
    If vProducts(l) <> 0 Then
    m = 1
    For i = 1 To 7
        For j = 2 To 8
            For k = 3 To 9
                If j > i And k > j Then
                    z = i * j * k
                    If z = vProducts(l) Then
                        vArray(m, 1) = i
                        vArray(m, 2) = j
                        vArray(m, 3) = k
                        m = m + 1
                    End If
                End If
            Next k
        Next j
    Next i
    Cells(2, 4 * (l + 2)).Resize(10, 3) = vArray
    End If
    Next l
End Sub
```

The code above uses the COUNTIF method that I suggested, but it does it right at the start, rather than in the loop. Seems to do the job on my PC...

Still to do --
3. Loop through BDFH Possibles, looking for matches with the factor sets. 
This could either use a modification of your approach, or a hunt for pairwise matches in the factor sets. It occurs to me that if all three factors in a triplet match with a BDFH row, you leave that triplet out of that loop because you are guaranteed to have a duplicate value in the final result. 

Denis


----------



## SydneyGeek (Oct 23, 2006)

It looks like the issue was with the loop I built, not the COUNTIF function as such. This version of BDFH Possibles works better (I keep forgetting that it's best to step up from the bottom when deleting cells) -- also did something silly with the Factors routine:


```
Sub SolveGrid()
    Dim Outcomes(0 To 4) As Variant
    Dim Answers(1 To 8) As Variant
    Dim i As Integer, j As Integer, l As Integer, x As Integer, y As Integer, z As Integer
    Dim m As Long, n As Long, p As Long
    
    'initialise arrays
    For z = 1 To 8
        Answers(z) = 0
    Next z
    Outcomes(0) = Range("C3").Value
    Outcomes(1) = Range("C2").Value
    Outcomes(2) = Range("D3").Value
    Outcomes(3) = Range("C4").Value
    Outcomes(4) = Range("B3").Value
    
    'set up reference values in worksheet
    PrepareStartVals
    Factors
    BDFH_Possibles
End Sub
Sub PrepareStartVals()
    Range("G:AG").ClearContents
    Range("G1").Value = "BDFH Possibles"
    Range("L1") = "ABH Factors"
    Range("P1") = "BCD Factors"
    Range("T1") = "DEF Factors"
    Range("X1") = "FGH Factors"
    
End Sub

Sub BDFH_Possibles()
    Dim i As Integer, j As Integer, k As Integer, l As Integer, z As Integer
    Dim iSum As Integer
    Dim m As Long, x As Long, Rw As Long, RwLast As Long
    Dim c As Range
    Dim vArray() As Variant
    
    x = 30 'arbitrary, but overkill for the # of possible options
    iSum = Range("C3").Value
    ReDim vArray(1 To x, 1 To 4)
    m = 1
    For i = 1 To 6
        For j = 2 To 7
            For k = 3 To 8
                For l = 4 To 9
                    If j > i And k > j And l > k Then
                        z = i + j + k + l
                        If z = iSum Then
                            vArray(m, 1) = i
                            vArray(m, 2) = j
                            vArray(m, 3) = k
                            vArray(m, 4) = l
                            m = m + 1
                        End If
                    End If
                Next l
            Next k
        Next j
    Next i
    Range("G2").Resize(x, 4) = vArray
    'remove any rows containing disallowed factors
    RwLast = Range("G65536").End(xlUp).Row
    For Rw = RwLast To 2 Step -1
        For Each c In Cells(Rw, 7).Resize(1, 4)
        If WorksheetFunction.CountIf(Range("L2:Z10"), c.Value) = 0 Then _
           Cells(c.Row, 7).Resize(1, 4).Delete
        Next c
    Next Rw
    
End Sub

Sub Factors()
    Dim vProducts(1 To 4) As Variant 'holds the 4 3-way products
    Dim vArray(1 To 3) As Variant
    Dim i As Integer, j As Integer, k As Integer, l As Integer
    Dim z As Integer
    Dim m As Long
    
    vProducts(1) = Range("C2").Value
    vProducts(2) = Range("D3").Value
    vProducts(3) = Range("C4").Value
    vProducts(4) = Range("B3").Value
    
    For l = 1 To 4
    If vProducts(l) <> 0 Then
    m = 2
    For i = 1 To 7
        For j = 2 To 8
            For k = 3 To 9
                If j > i And k > j Then
                    z = i * j * k
                    If z = vProducts(l) Then
                        vArray(1) = i
                        vArray(2) = j
                        vArray(3) = k
                        Cells(m, 4 * (l + 2)).Resize(1, 3) = vArray
                        m = m + 1
                    End If
                End If
            Next k
        Next j
    Next i
    
    End If
    Next l
End Sub
```
Denis


----------



## Andrew Fergus (Dec 11, 2006)

Hi Tom and Denis

After much procrastination and many delays, I think I finally have some robust code for your original question.  The issue with my previous version was the vlookup function was failing (timing perhaps?) so I've done a re-write and after corresponding with Denis (thanks for the tips Denis!) I have sped it up immensely by eliminating possible combinations from the outer loop (aka BDFH).  I also took this one step further and didn't bother calculating the factors for the 4 outer values - rather I went straight for the 3rd value to make the maths work.  Lastly, I no longer store the values on the spreadsheet and use arrays instead - but given I can't declare a public array, the code has ended up as one long list of tasks instead of being broken into logical modules.  Here is the code :


```
Option Explicit

'************************************************************************
'
'This code was developed by Andrew Fergus on 18 October 2006
'and finally modified on December 11th 2006 after much procrastination
'in response to this question on MrExcel:
'http://www.mrexcel.com/board2/viewtopic.php?t=238026
'
'************************************************************************

Public Sub SolvePuzzle()

Dim Answers(8) As Integer, _
    Values(9, 2) As Integer, _
    Finished(4) As Boolean, _
    Outcome(4) As Integer, _
    OuterLoop As Integer, _
    InnerLoop As Integer, _
    Loop1 As Integer, _
    Loop2 As Integer, _
    Loop3 As Integer, _
    Loop4 As Integer, _
    LoopLimit As Integer, _
    RowCounter As Integer, _
    TempVar1 As Integer, _
    TempVar2 As Double
    
'Values variable:
'   holds the values 0 through 9
'   dimension 0 is used to hold the value
'   dimension 1 is used to hold the used value (where 1 = used, 0 = unused)
'   dimension 2 holds how many times this value is used as a factor

'Initialise variables
'Get the 5 starting values
Outcome(0) = Range("C3").Value
Outcome(1) = Range("C2").Value
Outcome(2) = Range("D3").Value
Outcome(3) = Range("C4").Value
Outcome(4) = Range("B3").Value

'Clear the target area
Range("G1:J15").ClearContents
'Set the headings
Range("G1") = "BDFH Possibles"

'Set the array starting values
For Loop1 = 0 To 9
    Values(Loop1, 0) = Loop1             'the value
    Values(Loop1, 1) = 0                 'not used
    Values(Loop1, 2) = 0                 'no factors (yet)
Next

'Set initial answers to zero
For Loop1 = 0 To 8
    Answers(Loop1) = 0
Next

If Outcome(0) = 0 Then
    'There is not a unique answer
    MsgBox "The middle value cannot be zero.  Please try other numbers", vbCritical, "Error"
    Exit Sub
ElseIf Outcome(0) = 6 Then
    'BDFH is the minima (0,1,2,3)
    Range("G2") = 0
    Range("H2") = 1
    Range("I2") = 2
    Range("J2") = 3
    LoopLimit = 2
ElseIf Outcome(0) = 30 Then
    'BDFH is the maxima (6,7,8,9)
    Range("G2") = 6
    Range("H2") = 7
    Range("I2") = 8
    Range("J2") = 9
    LoopLimit = 2
Else
    'Find the possible combinations of values for positions BDFH
    LoopLimit = GetBDFH(Outcome(0))
End If

'Get all possible factors for the other 4 outcomes
For OuterLoop = 1 To 4
    If Outcome(OuterLoop) = 0 Then
        For Loop1 = 0 To 9
            Values(Loop1, 2) = Values(Loop1, 2) + 1
        Next
    Else
        For Loop1 = 1 To 9
            If Outcome(OuterLoop) Mod Loop1 = 0 Then
                Values(Loop1, 2) = Values(Loop1, 2) + 1
            End If
        Next
    End If
Next

'Remove the BDFH combinations that include non-existent factors
'and seek instances where there are two products that equal zero
For Loop1 = 0 To 9
    If Values(Loop1, 2) = 0 Then
        'This digit is not used
        For Loop2 = 2 To LoopLimit
            If Range("G" & Loop2).Value = Loop1 _
                Or Range("H" & Loop2).Value = Loop1 _
                Or Range("I" & Loop2).Value = Loop1 _
                Or Range("J" & Loop2).Value = Loop1 Then
                    'Delete this row of BDFH possibles - it cannot be used
                    Range("G" & Loop2 & ":J" & Loop2).Delete Shift:=xlShiftUp
                    'But we need to retest the row that now occupies the row deleted
                    LoopLimit = LoopLimit - 1
                    Loop2 = Loop2 - 1
            End If
        Next
    Else
        If Loop1 = 0 Then
            If Values(0, 2) > 1 Then
                MsgBox "There is more than one result.  Try other numbers", vbCritical, "Error"
                Exit Sub
            End If
        End If
    End If
Next

For OuterLoop = 2 To LoopLimit
'Loop through all combinations of BDFH
    'Get the starting values around Outcome(0)
    Answers(2) = Range("G" & OuterLoop).Value
    Answers(4) = Range("H" & OuterLoop).Value
    Answers(6) = Range("I" & OuterLoop).Value
    Answers(8) = Range("J" & OuterLoop).Value
    For Loop2 = 1 To 4
    'Loop through the 4 corner values (around BDFH)
        If Loop2 > 1 Then
        'Rotate the values around Outcome(0)
            Answers(0) = Answers(8)
            For Loop1 = 8 To 2 Step -2
                Answers(Loop1) = Answers(Loop1 - 2)
            Next
        End If
        For Loop3 = 1 To 6
            If Loop3 > 1 Then
            'Rotate the last 3 values around Outcome(0), but fix the lowest value
                Select Case Loop2
                    Case 1
                        If Loop3 Mod 2 = 0 Then
                        'Mod and case used to decide which pair of digits to swap
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        End If
                    Case 2
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(6)
                            Answers(6) = Answers(0)
                        Else
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case 3
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(8)
                            Answers(8) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                    Case Else
                        If Loop3 Mod 2 = 0 Then
                            Answers(0) = Answers(6)
                            Answers(6) = Answers(4)
                            Answers(4) = Answers(0)
                        Else
                            Answers(0) = Answers(4)
                            Answers(4) = Answers(2)
                            Answers(2) = Answers(0)
                        End If
                End Select
            End If
            
            'Reset variables
            For Loop1 = 0 To 9
                Values(Loop1, 1) = 0
            Next
            For Loop1 = 1 To 4
                Values(Answers(Loop1 * 2), 1) = 1
            Next
            Answers(1) = 0
            Answers(3) = 0
            Answers(5) = 0
            Answers(7) = 0
            For Loop1 = 1 To 4
                Finished(Loop1) = False
            Next
            
            'Set the 4 product values
            
            'Check the first outcome
            If Outcome(1) = 0 Then
                TempVar2 = 0
            Else
                'Calculate the factor
                TempVar2 = Outcome(1) / (Answers(2) * Answers(8))
            End If
            If TempVar2 < 10 And Int(TempVar2) = TempVar2 Then
                'This is a possible factor (integer < 9)
                If Values(TempVar2, 1) = 0 Then
                    'This value has not been used yet
                    Values(TempVar2, 1) = 1
                    Answers(1) = TempVar2
                    Finished(1) = True
                Else
                    'This value has already been used
                    Finished(1) = False
                    'No point testing the other 3 products
                    GoTo Skip_To_Here
                End If
            Else
                'This is not a valid factor
                Finished(1) = False
                'No point testing the other 3 products
                GoTo Skip_To_Here
            End If
            
            'Check 2nd outcome
            If Outcome(2) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(2) / (Answers(2) * Answers(4))
            End If
            If TempVar2 < 10 And Int(TempVar2) = TempVar2 Then
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(3) = TempVar2
                    Finished(2) = True
                Else
                    Finished(2) = False
                    GoTo Skip_To_Here
                End If
            Else
                Finished(2) = False
                GoTo Skip_To_Here
            End If
            
            'Check 3rd outcome
            If Outcome(3) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(3) / (Answers(4) * Answers(6))
            End If
            If TempVar2 < 10 And Int(TempVar2) = TempVar2 Then
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(5) = TempVar2
                    Finished(3) = True
                Else
                    Finished(3) = False
                    GoTo Skip_To_Here
                End If
            Else
                Finished(3) = False
                GoTo Skip_To_Here
            End If
            
            'Check 4th outcome
            If Outcome(4) = 0 Then
                TempVar2 = 0
            Else
                TempVar2 = Outcome(4) / (Answers(6) * Answers(8))
            End If
            If TempVar2 < 10 And Int(TempVar2) = TempVar2 Then
                If Values(TempVar2, 1) = 0 Then
                    Values(TempVar2, 1) = 1
                    Answers(7) = TempVar2
                    Finished(4) = True
                Else
                    Finished(4) = False
                End If
            Else
                Finished(4) = False
            End If
            
Skip_To_Here:
            
            If Finished(1) = True And Finished(2) = True And Finished(3) = True And Finished(4) = True Then
                GoTo JumpOut        'Yes I know this is sloppy but hey it works!
            End If
        Next
    Next
Next

'If the code has ended up here it has looped through every combination
MsgBox "Answer not found"
Range("C1").Value = "?"
Range("D2").Value = "?"
Range("E3").Value = "?"
Range("D4").Value = "?"
Range("C5").Value = "?"
Range("B4").Value = "?"
Range("A3").Value = "?"
Range("B2").Value = "?"
Exit Sub

'If a combination is found then the loop jumps out to here
JumpOut:
'Display the answers
Range("C1").Value = Answers(1)
Range("D2").Value = Answers(2)
Range("E3").Value = Answers(3)
Range("D4").Value = Answers(4)
Range("C5").Value = Answers(5)
Range("B4").Value = Answers(6)
Range("A3").Value = Answers(7)
Range("B2").Value = Answers(8)

MsgBox "Finished", vbInformation, "Done"

End Sub

Private Function GetBDFH(Outcome As Integer) As Integer

Dim RowCounter As Integer, _
    Loop1 As Integer, _
    Loop2 As Integer, _
    Loop3 As Integer, _
    Loop4 As Integer

RowCounter = 2

For Loop1 = 1 To 5
    For Loop2 = (Loop1 + 1) To 6
        For Loop3 = (Loop2 + 1) To 7
            For Loop4 = (Loop3 + 1) To 9
                If Loop1 + Loop2 + Loop3 + Loop4 = Outcome Then
                    Range("G" & RowCounter) = Loop1
                    Range("H" & RowCounter) = Loop2
                    Range("I" & RowCounter) = Loop3
                    Range("J" & RowCounter) = Loop4
                    RowCounter = RowCounter + 1
                End If
            Next
        Next
    Next
Next

GetBDFH = RowCounter - 1

End Function
```

Andrew


----------



## SydneyGeek (Dec 11, 2006)

Hi Andrew, 

It's definitely quicker than the first attempts! 
Interesting how much code goes into reproducing the thought processes of a 9-year old 

Denis


----------



## Andrew Fergus (Dec 11, 2006)

Hi Denis

Yes it is much faster (with thanks to you!).  How does one time how quickly the code runs?  If I capture the start and end times, it is only to the second and this code starts and stops in the same second (on my PC).  Is it possible to capture the milliseconds?  If so, how?

I suspect a 9yo uses trial and error plus intuition to crack one corner of the puzzle - once you have one corner, then the rest falls into place (much like SuDoKu).  When Tom posted this question I immediately recognised the puzzle because my son used to bring these home from school too - hence my interest in the question.  But you are right - hours of coding for a puzzle a 9yo can complete in 10 minutes or less.

Cheers and thanks for your guidance!
Andrew


----------



## SydneyGeek (Dec 11, 2006)

Hi Andrew, you're welcome -- I had some fun with the puzzle   

I found that there's a timeGetTime function in Windows that times to the millisecond. 

You insert this at the top of a module:

```
Public Declare Function timeGetTime _
   Lib "kernel32" ( ) As Long
```

Then something like

```
StartTime =timeGetTime()

'...and
EndTime = timeGetTime()

'Subtract them and you're done
```

Denis


----------



## Andrew Fergus (Dec 12, 2006)

Hi Denis
Do I need to enable any references to get that to work?  I've tried it on 2 PC's (with Office 2K and 2003) without luck.
Andrew


----------



## SydneyGeek (Dec 12, 2006)

Hi Andrew, 

Found the problem. The reference that I got that from referenced the wrong library. Change the declaration at the top of the module to 

```
Public Declare Function timeGetTime _
   Lib "winmm.dll" () As Long
```
. You will get a duration in milliseconds -- 11 and 12 on my machine, in 2 different runs. 

Denis


----------



## SydneyGeek (Dec 12, 2006)

FWIW, I found this on the MS KnowledgeBase. It tests 2 high performance counters built into Windows: timeGetTime and QueryPerformanceCount. 

```
Declare Function QueryPerformanceCounter Lib "Kernel32" _
                           (X As Currency) As Boolean
Declare Function QueryPerformanceFrequency Lib "Kernel32" _
                           (X As Currency) As Boolean
Declare Function GetTickCount Lib "Kernel32" () As Long
Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub Test_Timers()
Dim Ctr1 As Currency, Ctr2 As Currency, Freq As Currency
Dim Count1 As Long, Count2 As Long, Loops As Long
'
' Time QueryPerformanceCounter
'
  If QueryPerformanceCounter(Ctr1) Then
    QueryPerformanceCounter Ctr2
    Debug.Print "Start Value: "; Format$(Ctr1, "0.0000")
    Debug.Print "End Value: "; Format$(Ctr2, "0.0000")
    QueryPerformanceFrequency Freq
    Debug.Print "QueryPerformanceCounter minimum resolution: 1/" & _
                Freq * 10000; " sec"
    Debug.Print "API Overhead: "; (Ctr2 - Ctr1) / Freq; "seconds"
  Else
    Debug.Print "High-resolution counter not supported."
  End If
'
' Time GetTickCount
'
  Debug.Print
  Loops = 0
  Count1 = GetTickCount()
  Do
    Count2 = GetTickCount()
    Loops = Loops + 1
  Loop Until Count1 <> Count2
  Debug.Print "GetTickCount minimum resolution: "; _
              (Count2 - Count1); "ms"
  Debug.Print "Took"; Loops; "loops"
'
' Time timeGetTime
'
  Debug.Print
  Loops = 0
  Count1 = timeGetTime()
  Do
    Count2 = timeGetTime()
    Loops = Loops + 1
  Loop Until Count1 <> Count2
  Debug.Print "timeGetTime minimum resolution: "; _
              (Count2 - Count1); "ms"
  Debug.Print "Took"; Loops; "loops"
End Sub
```
On my machine, timeGetTime has a resolution of 1 ms; QueryPerformanceCount has a resolution of 16 ms. 

(3 GHz Pentium 4, 512 MB RAM, Win XP SP2)

Denis


----------



## PA HS Teacher (Dec 14, 2006)

Interesting Problem.  I decided to attack the problem using a series of User Defined Functions, that return Collections.

The User Defined Function Math9YearOld() can be used in a spreadsheet to solve the problem:
http://www.box.net/public/3psd0h6la0

I'll post an image of the spreadsheet when I get home.

In A2 and Pasted Down
=Math9Yearold(B2,C2,D2,E2,F2)

The Math9YearOldFunction Returns a String with all Solutions to the Problem:

****************   Function Math9YearOld ************************
<font face=Courier New><SPAN style="color:#00007F">Function</SPAN> Math9YearOld(<SPAN style="color:#00007F">Optional</SPAN> GHB <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 40, _
                      <SPAN style="color:#00007F">Optional</SPAN> BAC <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 30, _
                      <SPAN style="color:#00007F">Optional</SPAN> CDE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 48, _
                      <SPAN style="color:#00007F">Optional</SPAN> EFG <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 0, _
                      <SPAN style="color:#00007F">Optional</SPAN> Center <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 14) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>
StartTime = timeGetTime()
<SPAN style="color:#00007F">Dim</SPAN> PotentialSolutions <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection <SPAN style="color:#007F00">' Collection of Potential Solutions</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> Answers <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection  <SPAN style="color:#007F00">' Collection of Correct Solutions</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> GHBs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> BACs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> CDEs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection           <SPAN style="color:#007F00">' A Colection for each triplet of the combinations that</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> EFGs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection           <SPAN style="color:#007F00">' multiply to the corresponding constant above</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> GHBACs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> GHBACDEs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> GHBACDEFGs <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection

<SPAN style="color:#00007F">Set</SPAN> GHBs = Triplets(Factors(GHB), GHB)  <SPAN style="color:#007F00">'Collection of all possible Triplets Multiplying to GHB</SPAN>
<SPAN style="color:#00007F">Set</SPAN> BACs = Triplets(Factors(BAC), BAC)  <SPAN style="color:#007F00">'Collection of all possible Triplets Multiplying to BAC</SPAN>
<SPAN style="color:#00007F">Set</SPAN> CDEs = Triplets(Factors(CDE), CDE)  <SPAN style="color:#007F00">'Collection of all possible Triplets Multiplying to CDE</SPAN>
<SPAN style="color:#00007F">Set</SPAN> EFGs = Triplets(Factors(EFG), EFG)  <SPAN style="color:#007F00">'Collection of all possible Triplets Multiplying to EFG</SPAN>

<SPAN style="color:#007F00">' Possible Solutions are stored as a String of Numbers.  The first character of each String Correspods _
  to G, the second to H etc.  The collection of Possible Solutions is assembled by going through all _
  Possible combinations of one Family of Triplets with the Previous Families of Triplets.  Any _
  Solutions that repeat a digit are not included.</SPAN>
  
<SPAN style="color:#00007F">Set</SPAN> GHBACs = UniquePossibilities(GHBs, BACs)
<SPAN style="color:#00007F">Set</SPAN> GHBACDEs = UniquePossibilities(GHBACs, CDEs)
<SPAN style="color:#00007F">Set</SPAN> GHBACDEFGs = UniquePossibilities(GHBACDEs, EFGs, SkipLastDigit:=True)

<SPAN style="color:#007F00">' Collect the Possible Solutions that also Satisfy B+C+E+G = Center into a SolutionSet Collection</SPAN>
<SPAN style="color:#00007F">Set</SPAN> PotentialSolutions = CenterMet(GHBACDEFGs, 14)
<SPAN style="color:#007F00">' Check Solutions to make sure they meet all Criteria</SPAN>
Set Answers = VerifiedSolutions(PotentialSolutions, GHB, BAC, CDE, EFG, Center)

<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc <SPAN style="color:#00007F">In</SPAN> Answers
  S = S & "G = " & Mid(cc, 1, 1) & " H = " & Mid(cc, 2, 1) & " B = " & Mid(cc, 3, 1)
  S = S & " A = " & Mid(cc, 4, 1) & " C = " & Mid(cc, 5, 1)
  S = S & " D = " & Mid(cc, 6, 1) & " E = " & Mid(cc, 7, 1)
  S = S & " F = " & Mid(cc, 8, 1) & Chr(10)
<SPAN style="color:#00007F">Next</SPAN> cc
EndTime = timeGetTime()
Debug.Print S
Debug.Print "Elapsed Time: " & (Format(EndTime - StartTime)) & " ms?"
Math9YearOld = S
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN>
</FONT>

The Logic is similar to what Dennis suggested, (and I"m sure what Andrew Impletented, though I only skimmed his code).  Instead of using Loops and Arrays, I used Functions that return Collections.

*1.  For each of the 4 Multiplication requirement, determine the possible Factors (0 to 9) of the Required Number.*

****************   Function Factors ******************************
New><SPAN style="color:#00007F">Function</SPAN> Factors(N <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>
<SPAN style="color:#007F00">' Returns all Factors (0 to 9) of N</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
C.Add 0
<SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> 9
   <SPAN style="color:#00007F">If</SPAN> N Mod i = 0 <SPAN style="color:#00007F">Then</SPAN> C.Add i
<SPAN style="color:#00007F">Next</SPAN> i
<SPAN style="color:#00007F">Set</SPAN> Factors = C
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>

*2.  For each of the 4 Triplets, G*H*B, B*A*C, C*D*E, E*F*G, Assemble a collection of all possible 3 Factor Multiplications that yield the desired Number for Triplet.*

****************   Function Triplets ************************<font face=Courier [/size]New><SPAN style="color:#00007F">Function</SPAN> Triplets(Factors <SPAN style="color:#00007F">As</SPAN> Collection, N <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>
<SPAN style="color:#007F00">' Returns a Collection of all possible 3 digit combinations of Factors that multiply to N</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> Factors.Count
<SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> Factors.Count
<SPAN style="color:#00007F">For</SPAN> k = 1 <SPAN style="color:#00007F">To</SPAN> Factors.Count
   <SPAN style="color:#00007F">If</SPAN> Factors(i) <> Factors(j) And Factors(i) <> Factors(k) And Factors(j) <> Factors(k) <SPAN style="color:#00007F">Then</SPAN>
   <SPAN style="color:#00007F">If</SPAN> Factors(i) * Factors(j) * Factors(k) = N <SPAN style="color:#00007F">Then</SPAN>
      C.Add Factors(i) & Factors(j) & Factors(k)
   <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
   <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
<SPAN style="color:#00007F">Next</SPAN> k
<SPAN style="color:#00007F">Next</SPAN> j
<SPAN style="color:#00007F">Next</SPAN> i
<SPAN style="color:#00007F">Set</SPAN> Triplets = C
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>


*3.  Assemble a Collection of all Possible 4 Triplet Combinations by making 3 calls to the follwing Function.
A. (C1)  Because the Triplets Overal (e.g. GHB and BAC share B, All combinations where the Last Digit of the Previous Triplet does not Match the Left Digit of the Current Triplet are excluded.
B.  (C2) All Members of this Collection that repeat digits are excluded.
C.  (C3) Any Duplicate Members are Excluded.*


****************   Function UniquePossibilities ******************

<SPAN [/size]style="color:#00007F">Function</SPAN> UniquePossibilities(A <SPAN style="color:#00007F">As</SPAN> Collection, B <SPAN style="color:#00007F">As</SPAN> Collection, <SPAN style="color:#00007F">Optional</SPAN> SkipLastDigit <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN> = <SPAN style="color:#00007F">False</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C1 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection <SPAN style="color:#007F00">' Collection A & B's where the Last A = Last B  (In the game they overlap)</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C2 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection <SPAN style="color:#007F00">' Subset of C1 with No digits repeating</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C3 <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection <SPAN style="color:#007F00">' Same as C2 but no Duplicates</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> NotUnique <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>
ALen = Len(A(1))
ANum2 = A.Count
BLen = Len(B(1))
BNum2 = B.Count
LastDigit = ALen + BLen - 1
<SPAN style="color:#00007F">If</SPAN> SkipLastDigit <SPAN style="color:#00007F">Then</SPAN> LastDigit = LastDigit - 1

                   <SPAN style="color:#007F00">' C1 Collection A & B's where the Last A = Last B  (In the game they overlap)</SPAN>
<SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> ANum2
<SPAN style="color:#00007F">For</SPAN> j = 1 <SPAN style="color:#00007F">To</SPAN> BNum2
<SPAN style="color:#00007F">If</SPAN> Right(A(i), 1) = Left(B(j), 1) <SPAN style="color:#00007F">Then</SPAN> C1.Add A(i) & Right(B(j), Len(B(j)) - 1)
<SPAN style="color:#00007F">Next</SPAN> j
<SPAN style="color:#00007F">Next</SPAN> i

                   <SPAN style="color:#007F00">' C2 Subset of C1 with No digits repeating in any Solution</SPAN>
<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc <SPAN style="color:#00007F">In</SPAN> C1
NotUnique = <SPAN style="color:#00007F">False</SPAN>
  <SPAN style="color:#00007F">For</SPAN> i = ALen + 1 <SPAN style="color:#00007F">To</SPAN> LastDigit
    <SPAN style="color:#00007F">If</SPAN> InStr(1, Left(cc, ALen - 1), Mid(cc, i, 1)) > 0 <SPAN style="color:#00007F">Then</SPAN> NotUnique = <SPAN style="color:#00007F">True</SPAN>
  <SPAN style="color:#00007F">Next</SPAN> i
<SPAN style="color:#00007F">If</SPAN> NotUnique = <SPAN style="color:#00007F">False</SPAN> <SPAN style="color:#00007F">Then</SPAN>
   S = Left(cc, ALen) & Right(cc, BLen - 1)
   <SPAN style="color:#00007F">If</SPAN> SkipLastDigit <SPAN style="color:#00007F">Then</SPAN> S = Left(S, Len(S) - 1)
   C2.Add S
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
<SPAN style="color:#00007F">Next</SPAN> cc

                   <SPAN style="color:#007F00">'C3  Same as C2 but no Duplicates</SPAN>
<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc <SPAN style="color:#00007F">In</SPAN> C2
  AlreadyExists = <SPAN style="color:#00007F">False</SPAN>
  <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc3 <SPAN style="color:#00007F">In</SPAN> C3
     <SPAN style="color:#00007F">If</SPAN> cc3 = cc <SPAN style="color:#00007F">Then</SPAN> AlreadyExists = <SPAN style="color:#00007F">True</SPAN>
  <SPAN style="color:#00007F">Next</SPAN> cc3
  <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> AlreadyExists <SPAN style="color:#00007F">Then</SPAN> C3.Add cc
<SPAN style="color:#00007F">Next</SPAN> cc
<SPAN style="color:#00007F">Set</SPAN> UniquePossibilities = C3
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>

*4.  Potential Solutions that do not meet the requirement B+C+E+G=Center are excluded*

****************   Function CenterMet ************************
<font face=Courier New><SPAN style="color:#00007F">Function</SPAN> CenterMet(A <SPAN style="color:#00007F">As</SPAN> Collection, N <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>
<SPAN style="color:#007F00">' Returns a Collection of Solutions that Meet the requirement that B+C+E+G = N</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> S <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc <SPAN style="color:#00007F">In</SPAN> A
  S = 0
  S = S + Val(Mid(cc, 3, 1))
  S = S + Val(Mid(cc, 5, 1))
  S = S + Val(Mid(cc, 7, 1))
  S = S + Val(Mid(cc, 1, 1))
  <SPAN style="color:#00007F">If</SPAN> S = N <SPAN style="color:#00007F">Then</SPAN> C.Add cc
<SPAN style="color:#00007F">Next</SPAN> cc
<SPAN style="color:#00007F">Set</SPAN> CenterMet = C
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>

*5.  All Potential Solutions are Checked for Correctness*

****************   Function VerifiedSolutions *********************
<font face=Courier New><SPAN style="color:#00007F">Function</SPAN> VerifiedSolutions(A <SPAN style="color:#00007F">As</SPAN> Collection, GHB <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, BAC <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, CDE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, EFG <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>, Center <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>) <SPAN style="color:#00007F">As</SPAN> Collection
<SPAN style="color:#007F00">' Checks Potential Solutions in Collection A, returning a Collection of Correct Solutions</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> C <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">New</SPAN> Collection
<SPAN style="color:#00007F">Dim</SPAN> Sum <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> ConditionsMet <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>
<SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cc <SPAN style="color:#00007F">In</SPAN> A
Sum = 0
ConditionsMet = <SPAN style="color:#00007F">True</SPAN>
   ConditionsMet = ConditionsMet And (Val(Mid(cc, 1, 1)) * Val(Mid(cc, 2, 1)) * Val(Mid(cc, 3, 1))) = GHB
   ConditionsMet = ConditionsMet And (Val(Mid(cc, 3, 1)) * Val(Mid(cc, 4, 1)) * Val(Mid(cc, 5, 1))) = BAC
   ConditionsMet = ConditionsMet And (Val(Mid(cc, 5, 1)) * Val(Mid(cc, 6, 1)) * Val(Mid(cc, 7, 1))) = CDE
   ConditionsMet = ConditionsMet And (Val(Mid(cc, 7, 1)) * Val(Mid(cc, 8, 1)) * Val(Mid(cc, 1, 1))) = EFG
   Sum = Val(Mid(cc, 3, 1)) + Val(Mid(cc, 5, 1)) + Val(Mid(cc, 7, 1)) + Val(Mid(cc, 1, 1))
   ConditionsMet = ConditionsMet And Sum = Center
   <SPAN style="color:#00007F">If</SPAN> ConditionsMet <SPAN style="color:#00007F">Then</SPAN> C.Add cc
<SPAN style="color:#00007F">Next</SPAN> cc
<SPAN style="color:#00007F">Set</SPAN> VerifiedSolutions = C
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT>




*6.  Finally the Lead Function Math9YearOld() returns a String containing all possible Solutions.*

Using the timing function posted by Sydney, A correct answer is yielded in about 11 ms on my (slow) machine.  Tweaking numbers on the example spreadsheet, I was able to create 2 similar problems, one with 2 solutions.

I hope hope the hours I put in last night add something to this discussion.


PS - Tom, thank you immensely for your Object help this summer.  I'm teaching 5 classes this year, and I had to put the project down for a while, but I will come back to it eventually. (probably not till the summer, otherwise it will become too consuming.)  I have been extending your object oriented philosophy in some of my smaller projects.


----------



## Andrew Fergus (Dec 14, 2006)

Hi

It's nice to see an alternative solution to this puzzle.  I haven't gone through your code in detail yet (I will give it a whirl this weekend) but I noticed you refer to the solution in the plural - does your code produce more than one solution?

Andrew


----------



## PA HS Teacher (Dec 14, 2006)

Hi Andrew,
   I assume that for some values of the input parameters, there could be more than one valid solution.  For the Parameters in this problem, 
=Math9Yearold(40,30,48,0,14) yields the single solution:

G = 1 H = 8 B = 5 A = 3 C = 2 D = 4 E = 6 F = 0

however,
=Math9Yearold(40,6,48,0,14) yields two solutions:

G = 5 H = 4 B = 2 A = 3 C = 1 D = 8 E = 6 F = 0
G = 5 H = 8 B = 1 A = 3 C = 2 D = 4 E = 6 F = 0

I suppose it is possible that some comnations may yield more.

Most combinations of input parameters GHB, BAC, CDE, EFG, Center dont' seem to yield any solutions, and for certain combinations, the function seems like it may be caught in a loop.  I haven't tried that many combinations for the parameters, but I supose one could use this function in some loops to generate a list of all possible parameters, for this puzzle.

Assuming Only Numbers from 0 to 9 are used, and no digits are used more than once.


----------



## Andrew Fergus (Dec 14, 2006)

Interesting - I hadn't considered the possibility of multiple solutions - I was focused on just finding the one solution.  What combination(s) does your solution fail on?

Andrew


----------



## PA HS Teacher (Dec 14, 2006)

Here is what the sheet looks like.   I've added some rows with parameters to illustrate the function.Math 9 Year Old Function 12-4-06(1).xlsABCDEF1SolutionsGHBBACCDEEFGB+C+E+G2G = 1 H = 8 B = 5 A = 3 C = 2 D = 4 E = 6 F = 04030480143G = 5 H = 4 B = 2 A = 3 C = 1 D = 8 E = 6 F = 0 G = 5 H = 8 B = 1 A = 3 C = 2 D = 4 E = 6 F = 0406480144G = 4 H = 5 B = 3 A = 2 C = 1 D = 8 E = 6 F = 0606480145#VALUE!603480146#VALUE!601480147G = 7 H = 8 B = 1 A = 3 C = 2 D = 6 E = 4 F = 0566480148G = 7 H = 8 B = 1 A = 3 C = 2 D = 9 E = 4 F = 0566720149#VALUE!6767201410G = 0 H = 1 B = 5 A = 3 C = 2 D = 4 E = 7 F = 6 G = 0 H = 1 B = 5 A = 3 C = 2 D = 4 E = 7 F = 8 G = 0 H = 1 B = 5 A = 3 C = 2 D = 4 E = 7 F = 9 G = 0 H = 2 B = 5 A = 6 C = 1 D = 7 E = 8 F = 3 G = 0 H = 2 B = 5 A = 6 C = 1 D = 7 E = 8 F = 4 G = 0 H = 2 B = 5 A = 6 C = 1 D = 7 E = 8 F = 9 G = 0 H = 2 B = 6 A = 5 C = 1 D = 8 E = 7 F = 3 G = 0 H = 2 B = 6 A = 5 C = 1 D = 8 E = 7 F = 4 G = 0 H = 2 B = 6 A = 5 C = 1 D = 8 E = 7 F = 9 G = 0 H = 3 B = 5 A = 6 C = 1 D = 7 E = 8 F = 2 G = 0 H = 3 B = 5 A = 6 C = 1 D = 7 E = 8 F = 4 G = 0 H = 3 B = 5 A = 6 C = 1 D = 7 E = 8 F = 9 G = 0 H = 3 B = 6 A = 5 C = 1 D = 8 E = 7 F = 2 G = 0 H = 3 B = 6 A = 5 C = 1 D = 8 E = 7 F = 4 G = 0 H = 3 B = 6 A = 5 C = 1 D = 8 E = 7 F = 9 G = 0 H = 4 B = 5 A = 6 C = 1 D = 7 E = 8 F = 2 G = 0 H = 4 B = 5 A = 6 C = 1 D = 7 E = 8 F = 3 G = 0 H = 4 B = 5 A = 6 C = 1 D = 7 E = 8 F = 9 G = 0 H = 4 B = 6 A = 5 C = 1 D = 8 E = 7 F = 2 G = 0 H = 4 B = 6 A = 5 C = 1 D = 8 E = 7 F = 3 G = 0 H = 4 B = 6 A = 5 C = 1 D = 8 E = 7 F = 9 G = 0 H = 6 B =03056014Sheet1

Notice, some sets of Parameters yield more than one solution.
Row 3 has 2 solutions
Row 10 has 36 solutions! (though my approach allows for multiple 0 Targets)

I believe the #Value! is resulting from the inability to form a Triplet (3 Unique factors that multiply to one of the parameters.)

I have not been able to recreate the "endless loop" that I saw earlier.  Maybe the program had simply frozen when observed the behavior earlier?


----------



## Andrew Fergus (Dec 15, 2006)

The minimum value for one of the triplets is 6 (assuming the product is >0) given the three smallest values are 1, 2, 3 - the product of which is 6 so there are no possible solutions for rows 5 and 6.  Also row 9 contains a prime number as one of the triplet values so it only has one single digit factor and again the puzzle cannot be solved.  So it looks like your code is working fine.

Andrew


----------



## PA HS Teacher (Dec 16, 2006)

*Extension of Problem: All possible "Games"?*

I showed my wife the original puzzle, and she liked playing it, sort of like she plays Soduko.  I thought it would be fun to generate a list of "puzzles".  Same rules apply but with different constants.

Still no digits used more than once.
Still only digits 0 to 9.
Still GHB = a Constant
Still BAC = a Constant
Still CDE = a Constant
Still EFG = a Constant
Still B +C + E + G = a Constant

I am trying to assemble a list of 5 Constant Combinations that are solvable puzzles.

The largest possible Constant that a triplet can multiply to is 9*8*7 or 504.
The smallest (nonzero) is 1*2*3 or 6 as Andrew has pointed out.

The largest possible Constant that B+C+E+G can be is 9+8+7+6 or 30.
The smallest possible B + C + E + G = 0 + 1 + 2 + 3 = 6

None of the Target Constants for triplet multiplication can be a Prime Number as Andrew has also pointed out.

To start out, a brute force method would be to loop through all possible combinations using the logic above.  I've started this approach, but it would take days to weeks to run on my computer.

A Sheet called Not Possible Triplets, can help cut down some unncecessary looping, but not considering certain Target Constants for Triplet Multiplications:Math 9 Year Old Function All Possible 12-16-06.xlsABCD1TRUE2TRUE3TRUE4TRUE5TRUE6FALSE7TRUE8FALSE9FALSE10FALSE11TRUE12FALSE13TRUENot a Possible Triplet

A list of Valid Puzzles can be written to this Sheet.Math 9 Year Old Function All Possible 12-16-06.xlsABCDEF1SolutionsGHBBACCDEEFGB+C+E+G23Possible Puzzles

I have a button on the "Puzzles" Sheet with the following Code:<font face=Courier New><SPAN style="color:#00007F">Private</SPAN><SPAN style="color:#00007F">Sub</SPAN> CommandButton1_Click()<SPAN style="color:#00007F">Dim</SPAN> GHB<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN>, BAC<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN>, CDE<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN>, EFG<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN>, BCEG<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN><SPAN style="color:#00007F">Dim</SPAN> A<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">String</SPAN>, iRow<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Integer</SPAN><SPAN style="color:#00007F">Dim</SPAN> NotAPossibleTriplet(0<SPAN style="color:#00007F">To</SPAN> 504)<SPAN style="color:#00007F">As</SPAN><SPAN style="color:#00007F">Boolean</SPAN>
NotAPossibleTriplet(0) =<SPAN style="color:#00007F">False</SPAN><SPAN style="color:#00007F">For</SPAN> i = 1<SPAN style="color:#00007F">To</SPAN> 504
  NotAPossibleTriplet(i) = Worksheets("Not a Possible Triplet").Cells(i, 1).Value<SPAN style="color:#00007F">Next</SPAN> i
iRow = Range("B65535").End(xlUp).Row<SPAN style="color:#00007F">For</SPAN> GHB = 0<SPAN style="color:#00007F">To</SPAN> 504
                    <SPAN style="color:#00007F">If</SPAN> NotAPossibleTriplet(GHB)<SPAN style="color:#00007F">Then</SPAN><SPAN style="color:#00007F">GoTo</SPAN> ErrGHB<SPAN style="color:#00007F">For</SPAN> BAC = 0<SPAN style="color:#00007F">To</SPAN> 504
                    <SPAN style="color:#00007F">If</SPAN> NotAPossibleTriplet(BAC)<SPAN style="color:#00007F">Then</SPAN><SPAN style="color:#00007F">GoTo</SPAN> ErrBAC<SPAN style="color:#00007F">For</SPAN> CDE = 0<SPAN style="color:#00007F">To</SPAN> 504
                    <SPAN style="color:#00007F">If</SPAN> NotAPossibleTriplet(CDE)<SPAN style="color:#00007F">Then</SPAN><SPAN style="color:#00007F">GoTo</SPAN> ErrCDE<SPAN style="color:#00007F">For</SPAN> EFG = 0<SPAN style="color:#00007F">To</SPAN> 504
                    <SPAN style="color:#00007F">If</SPAN> NotAPossibleTriplet(EFG)<SPAN style="color:#00007F">Then</SPAN><SPAN style="color:#00007F">GoTo</SPAN> ErrEFG<SPAN style="color:#00007F">For</SPAN> BCEG = 6<SPAN style="color:#00007F">To</SPAN> 30
  <SPAN style="color:#00007F">On</SPAN><SPAN style="color:#00007F">Error</SPAN><SPAN style="color:#00007F">GoTo</SPAN> Err
  A = "Error"
  A = Math9YearOld(GHB, BAC, CDE, EFG, BCEG)
  <SPAN style="color:#00007F">If</SPAN> A = "Error"<SPAN style="color:#00007F">Then</SPAN><SPAN style="color:#00007F">GoTo</SPAN> Err
  iRow = iRow + 1
  Cells(iRow, 1) = A
  Cells(iRow, 2) = GHB
  Cells(iRow, 3) = BAC
  Cells(iRow, 4) = CDE
  Cells(iRow, 5) = EFG
  Cells(iRow, 6) = BCEG
  Cells(iRow, 7) = Now()
  Debug.Print GHB & " " & BAC & " " & CDE & " " & EFG & " " & BCEG & "    " & A & "  " & Format(Now(), "mm/dd/yy h:mm:ss")

Err:<SPAN style="color:#00007F">Next</SPAN> BCEG
ErrEFG<SPAN style="color:#00007F">Next</SPAN> EFG
ErrCDE<SPAN style="color:#00007F">Next</SPAN> CDE
ErrBAC:
Debug.Print GHB & " " & BAC & " " & CDE & " " & EFG & " " & BCEG & "    " & A & "  " & Format(Now(), "mm/dd/yy h:mm:ss")<SPAN style="color:#00007F">Next</SPAN> BAC
ErrGHB:<SPAN style="color:#007F00">'ThisWorkbook.Save</SPAN><SPAN style="color:#00007F">Next</SPAN> GHB<SPAN style="color:#00007F">End</SPAN><SPAN style="color:#00007F">Sub</SPAN></FONT>


This approach is too brute force.  I'd like to refine it, by reducing unnecessary looping.  Perhaps one could prescreen the constants in the loops before calling the Math9YearOld function.  If we know somehow ahead of time that the constant will not yield a solution, don't call the function.

I'm also considering the possiblity that instead of looping through constants sequentially, one could loop through a collection of possible contstants.  The collection of possible constants might be dependent on the current value of the more outer constant loops.  For example if every possible triplet for the outermost constant (GHB) requires a 1 in every possible triplet, then we can eliminate constants for the inner loop that require a 1 in every possible triplet for that constant.

This would allow us to reduce the number of loops.


btw: I modified Math9YearOld so that it returns "Error" if the function errors out rather than #Value!.  This allows these loops to keep running when the Math9YearOld function errors out.

Here's the file:
http://www.box.net/public/lj7srjiyau

thought it would take at least days to run completely as is.


----------



## Andrew Fergus (Dec 17, 2006)

Hi

It appears your technique for generating puzzles is starting at the possible solutions and working backwards.  When I first viewed this question I thought about producing a list of all possible puzzles based on using the values 0 through 9 in the 8 positions and working forwards.  However, I believe there hundreds of thousands (if not millions) of unique permutations.  I think you will find there are 6,720 unique solutions for 20,160 permutations where you have the number 0 in position A and the number 1 in position B.

So, rather than producing puzzles en masse, the following code will provide the eight final values and from that you can use math to calculate the 5 'clues', for one puzzle at a time.


```
Option Explicit

Public Sub MakeMeAPuzzle()

Dim tempValue(8) As Single, _
    ActualValue(8) As Integer, _
    ValuesToChoose(9) As Integer, _
    LoopCount As Integer, _
    InnerLoop As Integer, _
    PickDigit As Integer, _
    DigitCounter As Integer

'Resets the random seed
Randomize

For LoopCount = 1 To 8
    'I could have merged this with the line below but kept it seperate for debugging
    tempValue(LoopCount) = Rnd()
    'Multiply the random number by the number of choices left
    'Used one extra value plus the -0.5 to give the 2 end values the same chance of
    'being selected as the other values
    tempValue(LoopCount) = CInt(((11 - LoopCount) * tempValue(LoopCount)) - 0.5)
    'This number represents the digit to choose, based on the digits not yet used
Next

'Clear the used flag for the 10 possible choices
For LoopCount = 0 To 9
    ValuesToChoose(LoopCount) = 0
Next

For LoopCount = 1 To 8
    DigitCounter = 0
    PickDigit = tempValue(LoopCount)
    For InnerLoop = 0 To 9
        If ValuesToChoose(InnerLoop) = 0 Then
            'Not used yet
            If PickDigit = DigitCounter Then
                'Use this digit
                ValuesToChoose(InnerLoop) = 1
                ActualValue(LoopCount) = InnerLoop
                'Exit the inner loop
                InnerLoop = 9
            Else
                'Keep searching
                DigitCounter = DigitCounter + 1
            End If
        End If
    Next
Next

'Display the values
For LoopCount = 1 To 8
    Cells(2, LoopCount) = ActualValue(LoopCount)
Next

'The 4 triplet values are ActualValue(1*2*3) , ActualValue(3*4*5) , _
  ActualValue(5*6*7) , ActualValue(7*8*1)
'The inner value is ActualValue(1*3*5*7) - more correctly ActualValue(1) * ActualValue(3) etc.

End Sub
```

Andrew


----------

