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