For Fun and Learning Project

  • Thread starter Thread starter Legacy 98055
  • Start date Start date
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
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
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):
Code: 
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
 
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:

Code: 
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
 
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 :

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
 
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 :-D

Denis
 
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
 
Hi Andrew, you're welcome -- I had some fun with the puzzle :-D

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

You insert this at the top of a module:
Code: 
Public Declare Function timeGetTime _
   Lib "kernel32" ( ) As Long

Then something like
Code: 
StartTime =timeGetTime()

'...and
EndTime = timeGetTime()

'Subtract them and you're done

Denis
 
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
 
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
Code: 
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
 
FWIW, I found this on the MS KnowledgeBase. It tests 2 high performance counters built into Windows: timeGetTime and QueryPerformanceCount.
Code: 
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
 
You must log in or register to reply here.

Forum statistics

Threads
1,225,327
Messages
6,184,305
Members
453,227
Latest member
Slainte

Share this page

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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