Reconciliation problem

QuestionEdit

Is it possible to write some code to maketake reference from a user input cell and then look to a range of numbers in a column and find the individual numbers which add up to the user input number and then high light these numbers in yellow.

The problem has arose in a reconciliation where on one side transactions have been posted individually and on the other they have been posted in batches.

Any help would be greatly appreciated John

AnswerEdit

Copy the code below (written by Harlan Grove) into a code module, and set the references as instructed in the comments.

Then run findsums and highlight the ranges with your values when prompted.

Option Explicit 'Begin VBA Code

Sub findsums() 'This *REQUIRES* VBAProject references to

 'Microsoft Scripting Runtime
 'Microsoft VBScript Regular Expressions 1.0 or higher

 Const TOL As Double = 0.000001  'modify as needed
 Dim c As Variant

 Dim j As Long, k As Long, n As Long, p As Boolean
 Dim s As String, t As Double, u As Double
 Dim v As Variant, x As Variant, y As Variant
 Dim dc1 As New Dictionary, dc2 As New Dictionary
 Dim dcn As Dictionary, dco As Dictionary
 Dim re As New RegExp

 re.Global = True
 re.IgnoreCase = True

 On Error Resume Next

 Set x = Application.InputBox( _
   Prompt:="Enter range of values:", _
   Title:="findsums", _
   Default:="", _
   Type:=8 _
 )

 If x Is Nothing Then
   Err.Clear
   Exit Sub
 End If

 y = Application.InputBox( _
   Prompt:="Enter target value:", _
   Title:="findsums", _
   Default:="", _
   Type:=1 _
 )

 If VarType(y) = vbBoolean Then
   Exit Sub
 Else
   t = y
 End If

 On Error GoTo 0

 Set dco = dc1
 Set dcn = dc2

 Call recsoln

 For Each y In x.Value2
   If VarType(y) = vbDouble Then
     If Abs(t - y) < TOL Then
       recsoln "+" & Format(y)

     ElseIf dco.Exists(y) Then
       dco(y) = dco(y) + 1

     ElseIf y < t - TOL Then
       dco.Add Key:=y, Item:=1

       c = CDec(c + 1)
       Application.StatusBar = "[1] " & Format(c)

     End If

   End If
 Next y

 n = dco.Count

 ReDim v(1 To n, 1 To 3)

 For k = 1 To n
   v(k, 1) = dco.Keys(k - 1)
   v(k, 2) = dco.Items(k - 1)
 Next k

 qsortd v, 1, n

 For k = n To 1 Step -1
   v(k, 3) = v(k, 1) * v(k, 2) + v(IIf(k = n, n, k + 1), 3)
   If v(k, 3) > t Then dcn.Add Key:="+" & _
     Format(v(k, 1)), Item:=v(k, 1)
 Next k

 On Error GoTo CleanUp
 Application.EnableEvents = False
 Application.Calculation = xlCalculationManual

 For k = 2 To n
   dco.RemoveAll
   swapo dco, dcn

   For Each y In dco.Keys
     p = False

     For j = 1 To n
       If v(j, 3) < t - dco(y) - TOL Then Exit For
       x = v(j, 1)
       s = "+" & Format(x)
       If Right(y, Len(s)) = s Then p = True
       If p Then
         re.Pattern = "\" & s & "(?=(\+|$))"
         If re.Execute(y).Count < v(j, 2) Then
           u = dco(y) + x
           If Abs(t - u) < TOL Then
             recsoln y & s
           ElseIf u < t - TOL Then
             dcn.Add Key:=y & s, Item:=u
             c = CDec(c + 1)
             Application.StatusBar = "[" & Format(k) & "] " & _
                 Format(c)
           End If
         End If
       End If
     Next j
   Next y

   If dcn.Count = 0 Then Exit For
 Next k

 If (recsoln() = 0) Then _
   MsgBox Prompt:="all combinations exhausted", _
     Title:="No Solution"

CleanUp:

 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.StatusBar = False

End Sub

Private Function recsoln(Optional s As String)

 Const OUTPUTWSN As String = "findsums solutions"  'modify to taste

 Static r As Range
 Dim ws As Worksheet

 If s = "" And r Is Nothing Then
   On Error Resume Next
   Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)
   If ws Is Nothing Then
     Err.Clear
     Application.ScreenUpdating = False
     Set ws = ActiveSheet
     Set r = Worksheets.Add.Range("A1")
     r.Parent.Name = OUTPUTWSN
     ws.Activate
     Application.ScreenUpdating = False
   Else
     ws.Cells.Clear
     Set r = ws.Range("A1")
   End If
   recsoln = 0
 ElseIf s = "" Then
   recsoln = r.Row - 1
   Set r = Nothing
 Else
   r.Value = s
   Set r = r.Offset(1, 0)
   recsoln = r.Row - 1
 End If

End Function

Private Sub qsortd(v As Variant, lft As Long, rgt As Long)

 'ad hoc quicksort subroutine
 'translated from Aho, Weinberger & Kernighan,
 '"The Awk Programming Language", page 161

 Dim j As Long, pvt As Long

 If (lft >= rgt) Then Exit Sub
 swap2 v, lft, lft + Int((rgt - lft + 1) * Rnd)
 pvt = lft
 For j = lft + 1 To rgt
   If v(j, 1) > v(lft, 1) Then
     pvt = pvt + 1
     swap2 v, pvt, j
   End If
 Next j

 swap2 v, lft, pvt

 qsortd v, lft, pvt - 1
 qsortd v, pvt + 1, rgt

End Sub

Private Sub swap2(v As Variant, i As Long, j As Long)

 'modified version of the swap procedure from
 'translated from Aho, Weinberger & Kernighan,
 '"The Awk Programming Language", page 161

 Dim t As Variant, k As Long

 For k = LBound(v, 2) To UBound(v, 2)
   t = v(i, k)
   v(i, k) = v(j, k)
   v(j, k) = t
 Next k

End Sub

Private Sub swapo(a As Object, b As Object)

 Dim t As Object

 Set t = a
 Set a = b
 Set b = t

End Sub '---- end VBA code ----