Reconciliation problem

Last Edited By Krjb Donovan
Last Updated: Mar 05, 2014 09:52 PM GMT

Question

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

Answer

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 ----

Advertisement

©2020 eLuminary LLC. All rights reserved.