Add-ins:
Excel
PowerPoint

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?

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.

To learn more about recursion, see an introductory Computer Science textbook on programming techniques, search Google, or visit

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