Forum Discussion
KanwalNo1
May 25, 2024Iron Contributor
Allocating / Apportioning Challan Amounts to Different Receipts
(I Apologize Friends! I made the unpardonable mistake of uploading the wrong file here. Now I have Uploaded the correct file here. I sincerely apologize for the inconvenience ! Challan Allocation Ap...
- May 27, 2024
KanwalNo1 Thank you for providing the new file and additional clarification. The updated code below should do the trick for allocating amounts by ID and recording any shortages:
Option Explicit Sub AllocateReceipts() 'Clear the previous output range Application.ScreenUpdating = False Dim wsOutput As Worksheet Set wsOutput = Worksheets("ChallanAllocation") wsOutput.Range("A1").CurrentRegion.Offset(1).ClearContents 'Sort each table by id and date Dim loCha As ListObject, loRec As ListObject Set loCha = Worksheets("Challan").ListObjects("Challan") Set loRec = Worksheets("Receipts").ListObjects("Receipts") Call SortTable(loCha, 1, 3) Call SortTable(loRec, 1, 3) 'Load each table into an array Dim cha As Variant, rec As Variant cha = loCha.DataBodyRange.Value rec = loRec.DataBodyRange.Value 'Allocate receipts to challan amounts Dim arr(1 To 1, 1 To 6) As Variant, id As Variant, rowId As Long, i As Long, j As Long, k As Double rowId = 2 For i = 1 To UBound(rec, 1) ' check for new receipt id If rec(i, 1) <> id Then ' reset id and running total id = rec(i, 1) k = 0 End If ' validate receipt amount If rec(i, 4) > 0 Then ' loop through challan array until receipt amount has been exhausted For j = 1 To UBound(cha, 1) ' only allocate challan amounts with matching ids If cha(j, 1) = id And cha(j, 4) > 0 Then ' copy the transaction details to an array arr(1, 1) = rec(i, 1) '<-------------------------------------- ID arr(1, 2) = rec(i, 3) '<-------------------------------------- Receipt Date arr(1, 3) = IIf(cha(j, 4) < rec(i, 4), cha(j, 4), rec(i, 4)) ' Amount arr(1, 4) = arr(1, 3) + k '<---------------------------------- Running Total arr(1, 5) = cha(j, 2) '<-------------------------------------- CIN arr(1, 6) = cha(j, 3) '<-------------------------------------- CIN Date ' write the transaction array to the next output row wsOutput.Cells(rowId, 1).Resize(, 6).Value = arr rowId = rowId + 1 ' update the running total k = arr(1, 4) ' reduce the current amounts by the transaction amount cha(j, 4) = cha(j, 4) - arr(1, 3) rec(i, 4) = rec(i, 4) - arr(1, 3) If rec(i, 4) = 0 Then Exit For End If Next j ' verify receipt amount has been exhausted If rec(i, 4) > 0 Then ' record the shortage arr(1, 1) = rec(i, 1) '<--- ID arr(1, 2) = rec(i, 3) '<--- Receipt Date arr(1, 3) = rec(i, 4) '<--- Amount arr(1, 4) = arr(1, 3) + k ' Running Total arr(1, 5) = "Short" '<----- CIN arr(1, 6) = Null '<-------- CIN Date wsOutput.Cells(rowId, 1).Resize(, 6).Value = arr rowId = rowId + 1 k = arr(1, 4) End If End If Next i Application.ScreenUpdating = True End Sub Private Sub SortTable(table As ListObject, field1 As Long, field2 As Long) With table.Sort.SortFields .Clear .Add2 Key:=table.ListColumns(field1).Range, Order:=xlAscending .Add2 Key:=table.ListColumns(field2).Range, Order:=xlAscending End With With table.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub
Let me know how it goes. Cheers!
djclements
May 26, 2024Bronze Contributor
KanwalNo1 Some of your notes are a bit unclear and/or don't apply to the sample workbook provided (there is no ID column containing A01, A02, etc., there is nothing in cell Q49, and nowhere does the word "Short" appear in the CIN column).
Having said that, I was able to reproduce the current ChallanAllocation table results using VBA:
Option Explicit
Sub AllocateReceipts()
'Clear the previous output range
Application.ScreenUpdating = False
Sheet2.Range("A1").CurrentRegion.Offset(1).ClearContents
'Sort each table by date
Call SortTable(Sheet1.ListObjects("Receipts"), 2)
Call SortTable(Sheet1.ListObjects("Challan"), 2)
'Load each table into an array
Dim rec As Variant, cha As Variant
rec = Sheet1.ListObjects("Receipts").DataBodyRange.Value
cha = Sheet1.ListObjects("Challan").DataBodyRange.Value
'Allocate receipts to challan amounts
Dim arr(1 To 1, 1 To 5) As Variant, rowId As Long, i As Long, j As Long, k As Double
rowId = 2
For i = 1 To UBound(rec, 1)
If rec(i, 3) > 0 Then
For j = 1 To UBound(cha, 1)
If cha(j, 3) > 0 Then
' copy the transaction details to an array
arr(1, 1) = rec(i, 2) '<-------- Receipt Date
If cha(j, 3) < rec(i, 3) Then
arr(1, 2) = cha(j, 3) '<---- Amount (Challan)
Else
arr(1, 2) = rec(i, 3) '<---- Amount (Receipt)
End If
k = k + arr(1, 2) '<------------ Running Total
arr(1, 3) = k '<---------------- Running Total
arr(1, 4) = cha(j, 1) '<-------- CIN
arr(1, 5) = cha(j, 2) '<-------- CIN Date
' reduce the current amounts by the transaction amount
cha(j, 3) = cha(j, 3) - arr(1, 2)
rec(i, 3) = rec(i, 3) - arr(1, 2)
' write the transaction details to the next output row
Sheet2.Cells(rowId, 1).Resize(, 5).Value = arr
rowId = rowId + 1
If rec(i, 3) = 0 Then Exit For
End If
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
Private Sub SortTable(table As ListObject, column_num As Long)
With table.Sort.SortFields
.Clear
.Add2 Key:=table.ListColumns(column_num).Range, Order:=xlAscending
End With
With table.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
The AllocateReceipts sub is then called in the Worksheet_Activate event of the output sheet (Sheet2 in the attached sample workbook):
Option Explicit
Private Sub Worksheet_Activate()
Call AllocateReceipts
End Sub
Please note, this is just a starting point until additional feedback is provided. Also, the code does not currently allow for negative numbers in either the Challan table or the Receipts table. If negative numbers are a possibility, please explain how they should be handled and applied.
KanwalNo1
May 26, 2024Iron Contributor
Hi,
I sincerely apologize for making the unpardonable and stupid mistake of uploading the wrong file and wasting your valuable time.
My sincerest apologies to djclements SergeiBaklan PeterBartholomew1 lori_m Chris_Gross and to all the Esteemed Experts who took time to view my query.
I have NOW uploaded the correct file.
Apologies Again Friends!
I sincerely apologize for making the unpardonable and stupid mistake of uploading the wrong file and wasting your valuable time.
My sincerest apologies to djclements SergeiBaklan PeterBartholomew1 lori_m Chris_Gross and to all the Esteemed Experts who took time to view my query.
I have NOW uploaded the correct file.
Apologies Again Friends!