Multi select elements which sums upto a certain number from an array(II)

Sub Getit() Dim arr(1 To 65536, 1 To 1) As String, n As Long, t As Single Application.ScreenUpdating = False t = Timer Solve 88, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 12, 13, 14, 15, 16, 17, 18), arr, n If n > 0 Then MsgBox "Found " & n & " Solutions! It cost me about " & Format(Timer - t, "0.00000") & " seconds!", , "Info" [a1].Resize(n) = arr [a:a].Sort [a1] Else MsgBox "No solutions was Found!" End If Application.ScreenUpdating = True End Sub Sub Solve(ByVal Sum As Long, ByRef myarray, ByRef Result() As String, Optional ByRef num As Long) Dim n As Long, i As Long, Temp As Long, b() As Long n = UBound(myarray) - LBound(myarray) ReDim b(n + 1) While b(n + 1) < 1 Temp = 0 b(0) = b(0) + 1 For i = LBound(myarray) To UBound(myarray) If b(i) = 2 Then b(i) = 0 b(i + 1) = b(i + 1) + 1 End If If b(i) = 1 Then Temp = Temp + myarray(i) Next If Sum = Temp Then num = num + 1 For i = LBound(myarray) To UBound(myarray) If b(i) = 1 Then Result(num, 1) = Result(num, 1) & " " & myarray(i) Next Result(num, 1) = Replace(Trim(Result(num, 1)), " ", "+") & "=" & Sum End If If Temp >= Sum Then For i = LBound(myarray) To UBound(myarray) If b(i) = 1 Then Exit For b(i) = 1 Next b(1) = 1 End If Wend End Sub

It returns:

......

Total 8528 solutions within about 3 seconds.