﻿ Project Euler Problem 31
You are on the Home/Other Tutorials/Project Euler/Problem 31 page Share Your

# Project Euler - Problem 31

## Problem description

In England the currency is made up of pound, £, and pence, p, and there are eight coins in general circulation:

1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p).

It is possible to make £2 in the following way:

1x£1 + 1x50p + 2x20p + 1x5p + 1x2p + 3x1p

How many different ways can £2 be made using any number of coins?

## Solution

These kind of problems are ideally suited to solving by recursion.  The VBA code at ../../excel/templates/match_values/index.html solves a very similar problem.  In that scenario, the requirement was that each element be used only once.  Now, in Euler 31, we relax that restriction.  Luckily, enhancing the existing code is not very difficult.  We add an array InArrCounts of the same size as InArr.  Then, we add a loop where we count the number of times we use a particular element.  Make the necessary changes to correctly support this new array and we are done.  Well, almost.  It turns out the number of solutions we get exceed the capability of the Excel Transpose function.  Luckily, we don't need to list each solution, just the number.  So, that statement gets commented out.  Also, the original code does a lot more than the Euler 31 problem requires.  We could clean up the code to remove the extra code -- at the very least remove the debug statements? -- but is it worth the effort given that we can find the required answer in 3 or 4 seconds?

Once the code is in place, in 10 contiguous cells in an Excel worksheet enter the numbers 0, 200, 200, 100, 50, 20, 10, 5, 2, and 1.  The first 0 means we want all solutions.  The first 200 is the target amount (in pence).  The rest of the numbers are the denominations of the coins, all in pence.  Select this range and run the Euler31 subroutine.

Recursion
http://www.tushar-mehta.com/publish_train/book_vba/07_recursion.htm
```Option Explicit
Option Base 0

Function RealEqual(A, B, Epsilon As Double)
RealEqual = Abs(A - B) <= Epsilon
End Function
Function ExtendRslt(CurrRslt, NewVal, NewValCount, Separator)
If CurrRslt = "" Then ExtendRslt = NewVal & "(" & NewValCount & ")" _
Else ExtendRslt = CurrRslt & Separator & NewVal & "(" & NewValCount & ")"
End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, _
InArr(), InArrCounts() As Integer, _
ByVal CurrIdx As Integer, _
ByVal CurrTotal, ByVal Epsilon As Double, _
ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
Dim I As Integer
For I = CurrIdx To UBound(InArr)
Dim InArrCountsIdx As Integer
InArrCountsIdx = I - LBound(InArr) + LBound(InArrCounts)
For InArrCounts(InArrCountsIdx) = (TargetVal - CurrTotal) \ InArr(I) To 1 Step -1
If RealEqual(CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx), TargetVal, Epsilon) Then
Rslt(UBound(Rslt)) = (CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx)) _
& Separator & Format(Now(), "hh:mm:ss") _
& Separator & ExtendRslt(CurrRslt, I, InArrCounts(InArrCountsIdx), Separator)
If MaxSoln = 0 Then
If UBound(Rslt) Mod 100 = 0 Then Debug.Print UBound(Rslt) & "=" & Rslt(UBound(Rslt))
Else
If UBound(Rslt) >= MaxSoln Then Exit Sub
End If
ReDim Preserve Rslt(UBound(Rslt) + 1)
ElseIf CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx) > TargetVal + Epsilon Then
ElseIf CurrIdx < UBound(InArr) Then
recursiveMatch MaxSoln, TargetVal, InArr(), InArrCounts(), I + 1, _
CurrTotal + InArr(I) * InArrCounts(InArrCountsIdx), Epsilon, Rslt(), _
ExtendRslt(CurrRslt, I, InArrCounts(InArrCountsIdx), Separator), _
Separator
If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
Else
'we've run out of possible elements and we _
still don't have a match
End If
Next InArrCounts(I)
Next I
End Sub
Function ArrLen(Arr(), Optional ByVal ArrDim As Integer = 1) As Long
On Error Resume Next
ArrLen = UBound(Arr, ArrDim) - LBound(Arr, ArrDim) + 1
End Function
Sub Euler31()
'The selection should be a single contiguous range in a single column. _
The first cell indicates the number of solutions wanted.  Specify zero for all. _
The 2nd cell is the target value. _
The rest of the cells are the values available for matching. _
The output is in the column adjacent to the one containing the input data.
Dim TargetVal, Rslt(), InArr(), InArrCounts() As Integer, StartTime As Date, MaxSoln As Integer
StartTime = Now()
MaxSoln = Selection.Cells(1).Value
TargetVal = Selection.Cells(2).Value
InArr = Application.WorksheetFunction.Transpose( _
Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
ReDim InArrCounts(ArrLen(InArr) - 1)
ReDim Rslt(0)
recursiveMatch MaxSoln, TargetVal, InArr, InArrCounts, LBound(InArr), 0, 0.00000001, _
Rslt, "", ", "
Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
ReDim Preserve Rslt(UBound(Rslt) + 1)
Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
Debug.Print ArrLen(Rslt) - 2
'Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
Application.WorksheetFunction.Transpose(Rslt)
'Since there are >65536 solutions, the Transpose function fails.  Luckily, the problem requires _
finding just the number of solutions.
End Sub
```