3

This equation: a+(13*b/c)+d+(12*e)-f+(g*h/i)=87 appears when trying to solve the maths puzzle for Vietnamese eight-year-olds that recently became viral all over the Internet. In mathematics, such an equation is called an underdetermined system. Of course it has more than one solution and the brute force method seems to be the easiest way to find all of the solutions.

I'm interested in knowing how to solve the equation using VBA and present the solutions in an MS Excel worksheet, since I can't find a way to make such program due to my lack of VBA programming knowledge.

I'm aware of similar posts on Stack Overflow like this and this but the answers there do not help me much.

Here is my attempt:

Sub Vietnam_Problem()
Dim StartTime As Double

StartTime = Timer
j = 2   'initial value for number of rows
For a = 1 To 9
    For b = 1 To 9
        For c = 1 To 9
            For d = 1 To 9
                For e = 1 To 9
                    For f = 1 To 9
                        For g = 1 To 9
                            For h = 1 To 9
                                For i = 1 To 9
                                If a <> b And a <> c And a <> d And a <> e And a <> f And a <> g And a <> h And a <> i And b <> c And b <> d And b <> e And b <> f And b <> g And b <> h And b <> i And c <> d And c <> e And c <> f And c <> g And c <> h And c <> i And d <> e And d <> f And d <> g And d <> h And d <> i And e <> f And e <> g And e <> h And e <> i And f <> g And f <> h And f <> i And g <> h And g <> i And h <> i And a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
                                Cells(j, 1) = a
                                Cells(j, 2) = b
                                Cells(j, 3) = c
                                Cells(j, 4) = d
                                Cells(j, 5) = e
                                Cells(j, 6) = f
                                Cells(j, 7) = g
                                Cells(j, 8) = h
                                Cells(j, 9) = i
                                j = j + 1
                                End If
                                Next i
                            Next h
                        Next g
                    Next f
                Next e
            Next d
        Next c
    Next b
Next a
Cells(2, 11) = j - 2 'number of solutions
Cells(2, 12) = Round(Timer - StartTime, 2)  'running time of VBA code
End Sub

It seems to work but it's not nice and very slow.

Community
  • 1
  • 1

5 Answers5

9

Anastasiya-Romanova 秀, since you are not declaring the variables (a through j), your code is running with those variables defaulting to the Variant type. While variants can be enormously useful, they should not be used here.

I ran your code unaltered and on my machine, it took 851 seconds to complete.

Since VBA is optimized for Longs, simply adding one line to your code to declare the variables (a through j) as Longs, brought the running time on my machine down to 120 seconds. So that's seven times faster just for using the appropriate variable type!

My stab at solving this puzzle in VBA runs considerably faster. In fact, it's much faster (and shorter) than anything posted thus far on this page. On my same machine, it returns all 136 correct combinations in less than one second.

There is a lot of nonsense out there (the world, the net, even here on this page!) about VBA being too slow. Don't believe it. Sure, compiled languages can be faster, but much of the time it comes down to how well you know how to handle your language. I've been programming in the BASIC language since the 1970s.

Here is my solution to the Vietnam Puzzle that I crafted for your question. Please place this in a new code module:

Option Explicit
Private z As Long, v As Variant

Public Sub Vietnam()
    Dim s As String
    s = "123456789"
    ReDim v(1 To 200, 1 To 9)
    Call FilterPermutations("", s)
    [a1:i200] = v
    End
End Sub

Private Sub FilterPermutations(s1 As String, s2 As String)

    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, _
        g As Long, h As Long, i As Long, j As Long, m As Long, n As Long

    n = Len(s2)
    If n < 2 Then
        a = Mid$(s1, 1, 1):  b = Mid$(s1, 2, 1):  c = Mid$(s1, 3, 1)
        d = Mid$(s1, 4, 1):  e = Mid$(s1, 5, 1):  f = Mid$(s1, 6, 1)
        g = Mid$(s1, 7, 1):  h = Mid$(s1, 8, 1):  i = s2
        If a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
            z = z + 1
            v(z, 1) = a:  v(z, 2) = b:  v(z, 3) = c
            v(z, 4) = d:  v(z, 5) = e:  v(z, 6) = f
            v(z, 7) = g:  v(z, 8) = h:  v(z, 9) = i
        End If
    Else
        For m = 1 To n
            FilterPermutations s1 + Mid$(s2, m, 1), Left$(s2, m - 1) + Right$(s2, n - m)
        Next
    End If

End Sub

Method #2:

Anastasiya, I will try to explain it later today, when I have more time. But in the meantime, please examine my next stab at this. It is now even shorter and completes in about 1/10th of a second. I am now using Heap's Permutation Algorithm:

Option Explicit
Private z As Long, v As Variant

Public Sub VietnamHeap()
    Dim a(0 To 8) As Long
    a(0) = 1:  a(1) = 2:  a(2) = 3:  a(3) = 4:  a(4) = 5:  a(5) = 6:  a(6) = 7:  a(7) = 8:  a(8) = 9
    ReDim v(1 To 200, 1 To 9)
    Generate 9, a
    [a1:i200] = v
    End
End Sub

Sub Generate(n As Long, a() As Long)
    Dim t As Long, i As Long
    If n = 1 Then
        If a(0) + (13 * a(1) / a(2)) + a(3) + (12 * a(4)) - a(5) + (a(6) * a(7) / a(8)) = 87 Then
            z = z + 1
            For i = 1 To 9:  v(z, i) = a(i - 1):  Next
        End If
    Else
        For i = 0 To n - 2
            Generate n - 1, a
            If n Mod 2 = 1 Then
                t = a(0):  a(0) = a(n - 1):  a(n - 1) = t
            Else
                t = a(i):  a(i) = a(n - 1):  a(n - 1) = t
            End If
        Next
        Generate n - 1, a
    End If
End Sub

Method #3

And here is an even shorter version. Can anyone come up with either a shorter version or a quicker version?

Const q = 9
Dim z As Long, v(1 To 999, 1 To q)

Public Sub VietnamHeap()
    Dim a(1 To q) As Long
    For z = 1 To q: a(z) = z: Next: z = 0
    Gen q, a
    [a1].Resize(UBound(v), q) = v: End
End Sub

Sub Gen(n As Long, a() As Long)
    Dim i As Long, k As Long, t As Long
    If n > 1 Then
        For i = 1 To n - 1
            Gen n - 1, a
            If n Mod 2 = 1 Then k = 1 Else k = i
            t = a(k): a(k) = a(n): a(n) = t
        Next
        Gen n - 1, a
    Else
        If 87 = a(1) + 13 * a(2) / a(3) + a(4) + 12 * a(5) - a(6) + a(7) * a(8) / a(9) Then z = z + 1: For i = 1 To q: v(z, i) = a(i): Next
    End If
End Sub
Excel Hero
  • 14,253
  • 4
  • 33
  • 40
  • This is very neat! Can you add comment to your code since I'm new in VBA programming so that I can easily learn this topic? Thanks for suggestion. (+1) – Anastasiya-Romanova 秀 Jul 17 '15 at 06:47
  • Sir, when I tried to run the 2nd program (The Heap one) somehow the notification error showed up (run-time error '9'). What happened? – Anastasiya-Romanova 秀 Jul 17 '15 at 14:35
  • Anastasiya, can you please tell me which line is highlighted when you get the error? I'm not seeing an error here, and I've tried on several computers. – Excel Hero Jul 17 '15 at 16:50
  • There's no highlighted line when getting error. When I ran the heap program for the first time, it worked but when I ran again for the 2nd times or more I got error (run-time error '9'). – Anastasiya-Romanova 秀 Jul 17 '15 at 17:20
  • Please make sure that you click within the VietnamHeap() routine prior to running the code. – Excel Hero Jul 17 '15 at 17:35
  • I've looked at this and think the problem is the extreme recursiveness of the Heap algo implemented in Generate(). Nine symbol permutation is significant. Excel gets confused and does not completely end the program and unroll the entire stack. Strange indeed. However, the fix is easy. We simply add an "End" command at the bottom of VietnameHeap(). I've updated my answer. Try running the new version. – Excel Hero Jul 17 '15 at 18:54
  • 1
    Yep. It perfectly works with average run-time 0.597 in my laptop (I ran the program 10x). Thanks for your help. I'm still waiting you for adding comment in your code, though, but I'll wait until you have time to do that. Once again, thank you so much :) – Anastasiya-Romanova 秀 Jul 18 '15 at 06:48
2

I was going to submit another answer but since my last answer was pretty off base I've just overwritten it. This still uses a Monte Carlo style random number approach but it gets a bit lumpy when you have to make sure you haven't already solved with that random number combination.

Sub MonteCarlo()

Dim startTime As Single
startTime = Timer

Dim trialSol As Double
Dim solCounter As Integer
solCounter = 0

Dim trialNums() As Integer

Dim solutions As Collection
Set solutions = New Collection

Dim existingSol As Boolean
existingSol = False

Do

    trialNums = CreateRandomArray

    trialSol = ToSolve(trialNums(1), trialNums(2), _
                       trialNums(3), trialNums(4), _
                       trialNums(5), trialNums(6), _
                       trialNums(7), trialNums(8), _
                       trialNums(9))

    If trialSol = 87 Then

        If Not ExistsIn(solutions, trialNums) Then
            solutions.Add (trialNums)
        End If

    End If

Loop Until (solutions.Count = 128)

Dim solutionTime As Single
solutionTime = Round(Timer - startTime, 5)

Dim i As Integer
For i = 1 To solutions.Count
    Debug.Print "Solution " & i & ":"; vbTab; _
                solutions.Item(i)(1); vbTab; _
                solutions.Item(i)(2); vbTab; _
                solutions.Item(i)(3); vbTab; _
                solutions.Item(i)(4); vbTab; _
                solutions.Item(i)(5); vbTab; _
                solutions.Item(i)(6); vbTab; _
                solutions.Item(i)(7); vbTab; _
                solutions.Item(i)(8); vbTab; _
                solutions.Item(i)(9)
Next i
Debug.Print "Solution time: " & solutionTime & " ms"

End Sub

Function ExistsIn(col As Collection, arr() As Integer) As Boolean

    Dim ei As Boolean
    ei = False
    Dim i As Integer
    Dim temparr() As Integer

    If col.Count > 0 Then
        For i = 1 To col.Count
            temparr = col.Item(i)
            ei = AreEqual(temparr, arr)
        Next i
    End If

    ExistsIn = ei

End Function


Function AreEqual(array1() As Integer, array2() As Integer) As Boolean

    Dim eq As Boolean
    eq = True

    For i = LBound(array1) To UBound(array1)
       If array1(i) <> array2(i) Then
          eq = False
          Exit For
       End If
    Next i

    AreEqual = eq

End Function

Function ToSolve(a As Integer, b As Integer, _
                 c As Integer, d As Integer, _
                 e As Integer, f As Integer, _
                 g As Integer, h As Integer, _
                 i As Integer) As Double

    ToSolve = a + (13 * b / c) + d + (12 * e) - f + (g * h / i)

End Function

Function CreateRandomArray() As Integer()

    Dim numbers As New Collection
    Dim i As Integer

    For i = 1 To 9
        numbers.Add i
    Next i

    Dim rndNums(9) As Integer
    Dim rndInd As Integer

    For i = 1 To 9
        rndInt = CInt(((numbers.Count - 1) * Rnd) + 1)
        rndNums(i) = numbers(rndInt)
        numbers.Remove (rndInt)
    Next i

    CreateRandomArray = rndNums

End Function

My solution time for all combinations is around 3s - 3.5s.

stucharo
  • 865
  • 5
  • 19
1

Okay, here is my attempt:

Sub Vietnam_Problem()
Dim StartTime As Double

StartTime = Timer
j = 2   'initial value for number of rows
For a = 1 To 9
    For b = 1 To 9
        For c = 1 To 9
            For d = 1 To 9
                For e = 1 To 9
                    For f = 1 To 9
                        For g = 1 To 9
                            For h = 1 To 9
                                For i = 1 To 9
                                If a <> b And a <> c And a <> d And a <> e And a <> f And a <> g And a <> h And a <> i And b <> c And b <> d And b <> e And b <> f And b <> g And b <> h And b <> i And c <> d And c <> e And c <> f And c <> g And c <> h And c <> i And d <> e And d <> f And d <> g And d <> h And d <> i And e <> f And e <> g And e <> h And e <> i And f <> g And f <> h And f <> i And g <> h And g <> i And h <> i And a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
                                Cells(j, 1) = a
                                Cells(j, 2) = b
                                Cells(j, 3) = c
                                Cells(j, 4) = d
                                Cells(j, 5) = e
                                Cells(j, 6) = f
                                Cells(j, 7) = g
                                Cells(j, 8) = h
                                Cells(j, 9) = i
                                j = j + 1
                                End If
                                Next i
                            Next h
                        Next g
                    Next f
                Next e
            Next d
        Next c
    Next b
Next a
Cells(2, 11) = j - 2 'number of solutions
Cells(2, 12) = Round(Timer - StartTime, 2)  'running time of VBA code
End Sub

It seems to work but as I mentioned in the comment section below my question it's not nice and very slow.

The output:

a   b   c   d   e   f   g   h   i
1   2   6   4   7   8   3   5   9
1   2   6   4   7   8   5   3   9
1   3   2   4   5   8   7   9   6
1   3   2   4   5   8   9   7   6
1   3   2   9   5   6   4   7   8
1   3   2   9   5   6   7   4   8
1   3   4   7   6   5   2   9   8
1   3   4   7   6   5   9   2   8
1   3   6   2   7   9   4   5   8
1   3   6   2   7   9   5   4   8
1   3   9   4   7   8   2   5   6
1   3   9   4   7   8   5   2   6
1   4   8   2   7   9   3   5   6
1   4   8   2   7   9   5   3   6
1   5   2   3   4   8   7   9   6
1   5   2   3   4   8   9   7   6
1   5   2   8   4   7   3   9   6
1   5   2   8   4   7   9   3   6
1   5   3   9   4   2   7   8   6
1   5   3   9   4   2   8   7   6
1   9   6   4   5   8   3   7   2
1   9   6   4   5   8   7   3   2
1   9   6   7   5   2   3   4   8
1   9   6   7   5   2   4   3   8
2   1   4   3   7   9   5   6   8
2   1   4   3   7   9   6   5   8
2   3   6   1   7   9   4   5   8
2   3   6   1   7   9   5   4   8
2   4   8   1   7   9   3   5   6
2   4   8   1   7   9   5   3   6
2   8   6   9   4   1   5   7   3
2   8   6   9   4   1   7   5   3
2   9   6   3   5   1   4   7   8
2   9   6   3   5   1   7   4   8
3   1   4   2   7   9   5   6   8
3   1   4   2   7   9   6   5   8
3   2   1   5   4   7   8   9   6
3   2   1   5   4   7   9   8   6
3   2   4   8   5   1   7   9   6
3   2   4   8   5   1   9   7   6
3   2   8   6   5   1   7   9   4
3   2   8   6   5   1   9   7   4
3   5   2   1   4   8   7   9   6
3   5   2   1   4   8   9   7   6
3   6   4   9   5   8   1   7   2
3   6   4   9   5   8   7   1   2
3   9   2   8   1   5   6   7   4
3   9   2   8   1   5   7   6   4
3   9   6   2   5   1   4   7   8
3   9   6   2   5   1   7   4   8
4   2   6   1   7   8   3   5   9
4   2   6   1   7   8   5   3   9
4   3   2   1   5   8   7   9   6
4   3   2   1   5   8   9   7   6
4   3   9   1   7   8   2   5   6
4   3   9   1   7   8   5   2   6
4   9   6   1   5   8   3   7   2
4   9   6   1   5   8   7   3   2
5   1   2   9   6   7   3   4   8
5   1   2   9   6   7   4   3   8
5   2   1   3   4   7   8   9   6
5   2   1   3   4   7   9   8   6
5   3   1   7   2   6   8   9   4
5   3   1   7   2   6   9   8   4
5   4   1   9   2   7   3   8   6
5   4   1   9   2   7   8   3   6
5   4   8   9   6   7   1   3   2
5   4   8   9   6   7   3   1   2
5   7   2   8   3   9   1   6   4
5   7   2   8   3   9   6   1   4
5   9   3   6   2   1   7   8   4
5   9   3   6   2   1   8   7   4
6   2   8   3   5   1   7   9   4
6   2   8   3   5   1   9   7   4
6   3   1   9   2   5   7   8   4
6   3   1   9   2   5   8   7   4
6   9   3   5   2   1   7   8   4
6   9   3   5   2   1   8   7   4
7   1   4   9   6   5   2   3   8
7   1   4   9   6   5   3   2   8
7   2   8   9   6   5   1   3   4
7   2   8   9   6   5   3   1   4
7   3   1   5   2   6   8   9   4
7   3   1   5   2   6   9   8   4
7   3   2   8   5   9   1   6   4
7   3   2   8   5   9   6   1   4
7   3   4   1   6   5   2   9   8
7   3   4   1   6   5   9   2   8
7   5   2   8   4   9   1   3   6
7   5   2   8   4   9   3   1   6
7   6   4   8   5   9   1   3   2
7   6   4   8   5   9   3   1   2
7   9   6   1   5   2   3   4   8
7   9   6   1   5   2   4   3   8
8   2   4   3   5   1   7   9   6
8   2   4   3   5   1   9   7   6
8   3   2   7   5   9   1   6   4
8   3   2   7   5   9   6   1   4
8   5   2   1   4   7   3   9   6
8   5   2   1   4   7   9   3   6
8   5   2   7   4   9   1   3   6
8   5   2   7   4   9   3   1   6
8   6   4   7   5   9   1   3   2
8   6   4   7   5   9   3   1   2
8   7   2   5   3   9   1   6   4
8   7   2   5   3   9   6   1   4
8   9   2   3   1   5   6   7   4
8   9   2   3   1   5   7   6   4
9   1   2   5   6   7   3   4   8
9   1   2   5   6   7   4   3   8
9   1   4   7   6   5   2   3   8
9   1   4   7   6   5   3   2   8
9   2   8   7   6   5   1   3   4
9   2   8   7   6   5   3   1   4
9   3   1   6   2   5   7   8   4
9   3   1   6   2   5   8   7   4
9   3   2   1   5   6   4   7   8
9   3   2   1   5   6   7   4   8
9   4   1   5   2   7   3   8   6
9   4   1   5   2   7   8   3   6
9   4   8   5   6   7   1   3   2
9   4   8   5   6   7   3   1   2
9   5   3   1   4   2   7   8   6
9   5   3   1   4   2   8   7   6
9   6   4   3   5   8   1   7   2
9   6   4   3   5   8   7   1   2
9   8   6   2   4   1   5   7   3
9   8   6   2   4   1   7   5   3

There are 128 solutions and it took time 984.61 seconds or 16 minutes and 24.61 seconds.

1
Public j As Long '<--new line


Private Sub Permutate(list() As Long, ByVal pointer As Long)
  If pointer = UBound(list) Then
    Dim lower_bound As Long
    lower_bound = LBound(list)

    Validate list(lower_bound), list(lower_bound + 1), list(lower_bound + 2), list(lower_bound + 3), list(lower_bound + 4), list(lower_bound + 5), list(lower_bound + 6), list(lower_bound + 7), list(lower_bound + 8)

    Exit Sub
  End If

  Dim i As Long
  For i = pointer To UBound(list)
    Dim permutation() As Long
    permutation = list
    permutation(pointer) = list(i)
    permutation(i) = list(pointer)
    Permutate permutation, pointer + 1
  Next

End Sub

Private Sub Validate(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long, ByVal e As Long, ByVal f As Long, ByVal g As Long, ByVal h As Long, ByVal i As Long)

  If a + (13 * b / c) + d + (12 * e) - f + (g * h / i) = 87 Then
        Cells(j, 1) = a '<--new line
        Cells(j, 2) = b '<--new line
        Cells(j, 3) = c '<--new line
        Cells(j, 4) = d '<--new line
        Cells(j, 5) = e '<--new line
        Cells(j, 6) = f '<--new line
        Cells(j, 7) = g '<--new line
        Cells(j, 8) = h '<--new line
        Cells(j, 9) = i '<--new line
        j = j + 1 '<--new line
    'Debug.Print a, b, c, d, e, f, g, h, i
  End If
End Sub
Public Sub Vietnam_Problem()
  Dim numbers(1 To 9) As Long
  Dim i As Long
Dim StartTime As Double

StartTime = Timer
  j = 1 '<--new line

  For i = 1 To 9
    numbers(i) = i
  Next

  Permutate numbers, LBound(numbers)

Cells(2, 12) = Round(Timer - StartTime, 2)
End Sub
findwindow
  • 3,133
  • 1
  • 13
  • 30
0

Sorry - can't comment. I wouldn't use VBA or stuff for this. In my oppinion this is a job for logical languages like prolog. You can see some examples in multiple languages on the zebra-puzzle over here.

The only way in VBA I know is using for-loops - which isn't fast, which isn't nice, and which is very limited. This is why I'd advice logical languages like prolog or VERY FAST programming languages like C# / C++. Sorry for can't really helping you.

SophieXLove64
  • 316
  • 1
  • 11