Hello, below I have two modules for a workbook I created that reconciles dollar amounts. The idea behind it is let’s say you have an account with 20 open invoices. The client sends you a payment which if applied correctly will close 10 invoices. But the client doesn’t bother to send you any remittance advice. If you take the payment amount and enter it into the workbook along with all 20 invoices the workbook will highlight which amounts equal the payment. So in this case 10 invoices (or there amounts) will be highlighted. My problem with the workbook is it’ll only except about 20 invoices, around 25 it’ll take a full 4 minutes to compute. Anymore and it will just crash. If anyone here is willing, can you please take a look at my code to see if it can be optimized in anyway. I’d like for to take 100 invoices, or at least not crash. Maybe if it’s taking more than 2 minutes it can stop and say “memory exhausted, try again with a better computer.” I really hope someone can help, thanks!
Code:
'Code:1
'----------------------------------------------------------------------
Option Explicit
Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001)
RealEqual = Abs(A - B) <= Epsilon
End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
If CurrRslt = "" Then ExtendRslt = NewVal _
Else ExtendRslt = CurrRslt & Separator & NewVal
End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
ByVal HaveRandomNegatives As Boolean, _
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)
If RealEqual(CurrTotal + InArr(i), TargetVal, Epsilon) Then
Rslt(UBound(Rslt)) = (CurrTotal + InArr(i)) _
& Separator & Format(Now(), "hh:mm:ss") _
& Separator & ExtendRslt(CurrRslt, i, Separator)
If MaxSoln = 0 Then
'If UBound(Rslt) Mod 100 = 0 Then Debug.Print '"Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))
Else
If UBound(Rslt) >= MaxSoln Then Exit Sub
End If
ReDim Preserve Rslt(UBound(Rslt) + 1)
ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(i) > TargetVal + Epsilon) Then
ElseIf CurrIdx < UBound(InArr) Then
recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
i + 1, _
CurrTotal + InArr(i), Epsilon, Rslt(), _
ExtendRslt(CurrRslt, i, 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 i
End Sub
Function ArrLen(Arr()) As Long
'On Error Resume Next
ArrLen = UBound(Arr) - LBound(Arr) + 1
End Function
Function checkRandomNegatives(Arr) As Boolean
Dim i As Long
i = LBound(Arr)
Do While Arr(i) < 0 And i < UBound(Arr): i = i + 1: Loop
If i = UBound(Arr) Then Exit Function
Do While Arr(i) >= 0 And i < UBound(Arr): i = i + 1: Loop
checkRandomNegatives = Arr(i) < 0
End Function
Sub FindInvoice()
'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 lr As Long
Call sortData
lr = Sheet1.Range("C2").End(xlDown).Row
If lr < 2 Then
MsgBox "No Existing Invoice Found.Task cancelled", vbCritical
Exit Sub
Else
Sheet1.Range("C2:C" & lr).Select
End If
If Len(Sheet1.Range("C3")) < 1 Then
MsgBox "Please provide Total Amout to be matched.", vbExclamation
Sheet1.Range("C3").Select
Exit Sub
End If
If Not TypeOf Selection Is Range Then GoTo ErrXIT
If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
If Selection.Rows.Count < 3 Then GoTo ErrXIT
Debug.Print Now
Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
HaveRandomNegatives As Boolean
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)
HaveRandomNegatives = checkRandomNegatives(InArr)
If Not HaveRandomNegatives Then
ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
& vbNewLine _
& "It may take a lot longer to search for matches." & vbNewLine _
& "OK to continue else Cancel", vbOKCancel) = vbCancel Then
Exit Sub
End If
ReDim Rslt(0)
recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
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")
Sheets("Reconciler").Range("F3") = UBound(Rslt) - 1
Debug.Print Now
Sheet1.Range("H1").Resize(ArrLen(Rslt), 1).Value = _
Application.WorksheetFunction.Transpose(Rslt)
Sheet1.Range("C4:C100000").Interior.Color = 15853019
If Sheet1.Range("F3") > 0 Then Sheet1.Range("F4") = 0
Sheet1.Range("B3").Select
Call showMatch
Exit Sub
ErrXIT:
MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
& "The selection should be a single contiguous range in a single column." & vbNewLine _
& "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _
& "The 2nd cell is the target value." & vbNewLine _
& "The rest of the cells are the values available for matching." & vbNewLine _
& "The output is in the column adjacent to the one containing the input data."
End Sub
Sub reset()
Sheet1.Range("C4:C100000").Interior.Color = 15853019
Sheet1.Range("F10") = 0.99999
End Sub
Sub showMatch()
Dim Sc, i As Long, Mc As Long, r As Long
Sheet1.Range("C4:C100000").Interior.Color = 15853019
r = 1
If Sheet1.Range("F4") < Sheet1.Range("F3") Then
Sheet1.Range("F4") = Sheet1.Range("F4") + 1
Findmatch:
Mc = CLng(Sheet1.Range("F4"))
Sc = Split(Sheet1.Range("H" & Mc))
For i = 2 To UBound(Sc)
If IsNumeric(Sc(i)) = True Then Sheet1.Range("C" & Sc(i) + 3).Interior.Color = vbGreen
Next
r = r + 1
Else
If Sheet1.Range("F3") > 0 Then Sheet1.Range("F4") = 1
GoTo Findmatch
End If
End Sub
'--------------------------------------------------------------------------------
Sub sortData()
Dim lr As Long, prow As Long, i As Long
lr = Sheet1.Range("C2").End(xlDown).Row
Range("C4:C" & lr).Select
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Add Key:=Range( _
"C4"), SortOn:=xlSortOnValues, Order:=1, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reconciler").Sort
.SetRange Range("C4:C" & lr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = 4 To lr
If Worksheets("Reconciler").Cells(i, 3) >= 0 Then
prow = i
Exit For
End If
Next
Range("C" & prow & ":C" & lr).Select
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Add Key:=Range( _
"C" & prow), SortOn:=xlSortOnValues, Order:=2, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reconciler").Sort
.SetRange Range("C" & prow & ":C" & lr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
prow = prow - 1
If prow > 4 Then
Range("C4:C" & prow).Select
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reconciler").Sort.SortFields.Add Key:=Range( _
"C4"), SortOn:=xlSortOnValues, Order:=2, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reconciler").Sort
.SetRange Range("C4:C" & prow)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End Sub
Code:
Sub FindCloseInvoice()
'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.
Debug.Print Now
Dim lr As Long
lr = Sheet1.Range("C2").End(xlDown).Row
If lr < 2 Then
MsgBox "No Existing Invoice Found.Task cancelled", vbCritical
Exit Sub
Else
Sheet1.Range("C2:C" & lr).Select
End If
If Len(Sheet1.Range("C3")) < 1 Then
MsgBox "Please provide Total Amout to be matched.", vbExclamation
Sheet1.Range("C3").Select
Exit Sub
End If
If Not TypeOf Selection Is Range Then GoTo ErrXIT
If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
If Selection.Rows.Count < 3 Then GoTo ErrXIT
Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
HaveRandomNegatives As Boolean
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)
HaveRandomNegatives = checkRandomNegatives(InArr)
If Not HaveRandomNegatives Then
ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
& vbNewLine _
& "It may take a lot longer to search for matches." & vbNewLine _
& "OK to continue else Cancel", vbOKCancel) = vbCancel Then
Exit Sub
End If
ReDim Rslt(0)
recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
LBound(InArr), 0, CDbl(Sheet1.Range("F10")), _
Rslt, "", ", "
Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
ReDim Preserve Rslt(UBound(Rslt) + 1)
Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
Sheets("Reconciler").Range("F3") = UBound(Rslt) - 1
Debug.Print Now
'MsgBox ArrLen(Rslt)
Sheet1.Columns(8).ClearContents
Sheet1.Range("H1:H" & CLng((UBound(Rslt)))) = Rslt
'Sheet1.Range(.Offset(0, 0), .Offset(rNum - 1, cNum - 1)) = Results
Sheet1.Range("H1") = Application.WorksheetFunction.Transpose(Rslt)
'Sheet1.Range("H1").Resize(ArrLen(Rslt), 1).Value = _
Application.WorksheetFunction.Transpose(Rslt)
Sheet1.Range("H1").Resize(ArrLen(Rslt), 1).Value = Application.WorksheetFunction.Transpose(Rslt)
'Sheet1.Range("C4:C100000").Interior.Color = 15853019
If Sheet1.Range("F3") > 0 Then Sheet1.Range("F4") = 0
Sheet1.Range("B3").Select
Call showMatch
'Debug.Print Now
MsgBox "Done"
Exit Sub
ErrXIT:
MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
& "The selection should be a single contiguous range in a single column." & vbNewLine _
& "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _
& "The 2nd cell is the target value." & vbNewLine _
& "The rest of the cells are the values available for matching." & vbNewLine _
& "The output is in the column adjacent to the one containing the input data."
End Sub
