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