May 25 2024 02:03 AM - edited May 26 2024 07:46 PM
(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 Apportionment to Receipts.xlsx.
I have also uploaded one new workbook
Challan Allocation Apportionment to Receipts DJClements 02.xlsm [with additonal columns]. If anyone is working fresh on this query, kindly consider working on this file
The attached file contains three Tables
1. Challan : This table contains the data for the Tax deposited via Challan.
2. Receipts : This table contains the data for the Amounts received against which the tax has been deposited.
3. ChallanAllocation : This table contains the mapping (from Challan Table) of challan number and date to all the amounts (in the Receipts Table)
My Request involves creation of ChallanAllocation like Information in an automated way
Here one challan amount might be sufficient to cover multiple receipts
or
One receipt might be sufficient to cover multiple challans
Considering the Receipts Table as base We need to Map (allocate and / or apportion) the Challan amount to all the receipts on FIFO basis, without leaving any balance in challan, and create a new table (Structured Data Table or simple data range). We might need to split the single challan across various receipts OR split the single receipts across several challans and might need to ADD more rows to accommodate such splits.
Notes:
1. Challan date and Receipt Date need to be in ascending order, but Challan Date may be before or after the Receipt Date. I will enter the data in ascending order but appreciate if the proposed solution can sort the data based on ID and CIN Date / Receipt Date.
2. I have given data for only Two IDs (i.e., A01, A02) but there are multiple IDs for which Data is maintained in the same table.
3. Total Challan Amount and Total Receipt Amount is matching in case of A01 but might be different in other cases (like in A02). In case Total Challan Amount is MORE than the Total Receipt Amount, the balance can be ignored. But if the Challan Amount is LESS than the Receipt Amount, the additional row should appear with "Short" in CIN Column in ChallanAllocation Table (like in Cell Q49)
Any solution (VBA, non VBA) to solve this and create the desired data is EQUALLY appreciated.
As I am not very good in VBA, I am trying my best to find a Non VBA solution using Dynamic Array Functions, but I am struggling to add new rows automatically to the existing table.
In real scenario, I am going to use three different sheets (Challan, Receipts, ChallanAllocation) and will be copying the new data on the Challan and Receipts sheet, hoping that the solution will create the desired data in Sheet ChallanAllocation. Here for the sake of easy matching, I have kept the data on one sheet.
and to all the Esteemed Experts
May 26 2024 12:52 AM
@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.
May 26 2024 02:47 AM
May 26 2024 04:14 AM - edited May 26 2024 07:44 PM
Thanks Sir !
It seems to work perfectly as per the data provided in the original file.
Let me clarify that the actual purpose is to allocate the ID wise TOTAL Challan Amount to ID wise TOTAL Receipts, to the extent possible. It is not relevant whether the challan date is earlier or later than the receipt date. The JOINT sorting in the ChallanAllocation table is just to display the method of splitting the entries in case the challan need to be allocated.
So if for an ID
Challan Amount > Receipt Amount, we need to ignore that EXTRA amount and move to next ID. This Challan balance will be used in the next period for Allocation with the forthcoming period receipt entries.
Receipt Amount > Challan Amount, it means a shortfall in payment and so "Short" need to be mentioned instead of the CIN
May 26 2024 08:01 PM - edited May 26 2024 08:15 PM
Solution@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!
May 26 2024 09:31 PM - edited May 26 2024 09:36 PM
@djclements
Wooooooo ! You are a professional / passionate VBA Developer ! It looks great Sir !
I tried the following scenarios.
1. Changed the Challan amount in D18 to 1450. As expected, the row to add the "Short" entry was gone and receipt fully allocated. (10/10)
2. Changed the Challan Amount in D18 to 650. Shortfall inreased to 750 from 650 (10/10)
3. Changed the ID in A16 (Challan) to A03. But no receipt was shown in Receipt sheet for this ID. As expected, Shortfall was calculated correctly. The challan balance for A03 will be carried forward. (10/10)
4. Changed the ID in A33 in Receipts without any corresponding change in Challan sheet. Code updated the entry to reflect the changes for A02 and added a new entry for A03 shortfall (10/10)
Full Marks Sir!
I got late in submitting a new workbook with two additional columns in Challan sheet, which also need to be carried to ExpectedResults sheet. I have appended that new file too in the original question.
I am going to accept this answer as final. I request that If there are not too many modifications involved, then can you have a look at those columns which are there and need to be included in final results. Highly appreciated! No strings attached. It was my mistake to have overseen those columns.
This place has its worth in GOLD due to people like you! MAY the Almighty Bless you!
Sincere Regards
Kanwaljit
May 26 2024 10:55 PM
@KanwalNo1 Sorry, I must have been working on Rev.2 when you uploaded Rev.3. Here's the updated code to work with the additional columns:
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, 4, 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 😎 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, 5) > 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) '<----------------------------------- Party
arr(1, 3) = rec(i, 4) '<----------------------------------- Receipt Date
arr(1, 4) = WorksheetFunction.Min(cha(j, 4), rec(i, 5)) ' Amount
arr(1, 5) = WorksheetFunction.Round(arr(1, 4) * 0.001, 0) ' Tax Amt
arr(1, 6) = arr(1, 4) + k '<------------------------------- Running Total
arr(1, 7) = cha(j, 2) '<----------------------------------- CIN
arr(1, 😎 = cha(j, 3) '<----------------------------------- CIN Date
' write the transaction array to the next output row
wsOutput.Cells(rowId, 1).Resize(, 8).Value = arr
rowId = rowId + 1
' update the running total
k = arr(1, 6)
' reduce the current amounts by the transaction amount
cha(j, 4) = cha(j, 4) - arr(1, 4)
rec(i, 5) = rec(i, 5) - arr(1, 4)
If rec(i, 5) = 0 Then Exit For
End If
Next j
' verify receipt amount has been exhausted
If rec(i, 5) > 0 Then
' record the shortage
arr(1, 1) = rec(i, 1) '<----------------------------------- ID
arr(1, 2) = rec(i, 3) '<----------------------------------- Party
arr(1, 3) = rec(i, 4) '<----------------------------------- Receipt Date
arr(1, 4) = rec(i, 5) '<----------------------------------- Amount
arr(1, 5) = WorksheetFunction.Round(arr(1, 4) * 0.001, 0) ' Tax Amt
arr(1, 6) = arr(1, 4) + k '<------------------------------- Running Total
arr(1, 7) = "Short" '<------------------------------------- CIN
arr(1, 😎 = Null '<---------------------------------------- CIN Date
wsOutput.Cells(rowId, 1).Resize(, 8).Value = arr
rowId = rowId + 1
k = arr(1, 6)
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Private Sub SortTable(table As ListObject, field1 As Long, field2 As Long, Optional field3 As Long)
With table.Sort.SortFields
.Clear
.Add2 Key:=table.ListColumns(field1).Range, Order:=xlAscending
.Add2 Key:=table.ListColumns(field2).Range, Order:=xlAscending
If field3 > 0 Then
.Add2 Key:=table.ListColumns(field3).Range, Order:=xlAscending
End If
End With
With table.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Enjoy!
May 27 2024 12:30 AM
May 27 2024 09:13 AM
The attached attempts FIFO allocation using Excel Dynamic Array formulas.
The 'FIFOλ' was intended to allocate input costs to outputs and, at present, assigns #N/A to the 'cost' of inputs that have yet to be purchased.
May 27 2024 09:30 AM
Image and formula:
= LET(
ID, "A01",
outputID, FILTER(Receipts[Receipt Date], Receipts[ID]=ID),
outputQty, FILTER(Receipts[Amount], Receipts[ID]=ID),
inputID, FILTER(Challan[CIN Date], Challan[ID]=ID),
inputQty, FILTER(Challan[Amount], Challan[ID]=ID),
resultArr, FIFOλ(outputID,outputQty,inputID,inputQty,SIGN(inputQty),2),
resultArr
)
FIFOλ stacks all input and output events in order of accumulated quantity into a single array and sorts by accumulated quantity. With 365 insider the output can be switched between a basic table format and crosstab using PIVOTBY.
FIFOλ(OutputID, OutQty, InputID, InpuQty, PriceIn, [format])
=LET(
inpID, EXPAND(VSTACK(InputID, "On order"), , 2, ""),
cumInp, HSTACK(VSTACK(0, SCAN(0, InputQty, ADDλ)), priceIn),
outID, CHOOSECOLS(EXPAND(VSTACK(OutputID, "Stock"), , 2, ""), 2, 1),
cumOut, EXPAND(VSTACK(0, SCAN(0, OutQty, ADDλ)), , 2, ""),
transact, SORT(VSTACK(HSTACK(inpID, cumInp), HSTACK(outID, cumOut)), 3),
inpRef, Filldownλ(TAKE(inpID, 1, 1), CHOOSECOLS(transact, 1)),
outRef, Filldownλ(TAKE(outID, 1, -1), CHOOSECOLS(transact, 2)),
price, Filldownλ(TAKE(priceIn, 1, 1), CHOOSECOLS(transact, 4)),
cumAmt, CHOOSECOLS(transact, 3),
transAmt, DROP(cumAmt, 1) - cumAmt,
transactTbl, DROP(DROP(HSTACK(inpRef, outRef, transAmt, price), 1), -1),
inpHdr, CHOOSECOLS(transactTbl, 1),
outHdr, CHOOSECOLS(transactTbl, 2),
qty, CHOOSECOLS(transactTbl, 3),
uCost, CHOOSECOLS(transactTbl, 4),
SWITCH(
format,
0, VSTACK({"Input ID", "Output ID", "Quantity", "Unit cost"}, transactTbl),
1, VSTACK(
{"Output ID", "Quantity", "Cost"},
GROUPBY(outHdr, HSTACK(qty, qty * uCost), SUM, , 0)
),
2, PIVOTBY(outHdr, inpHdr, qty * uCost, SUM, , 0),
3, PIVOTBY(outHdr, inpHdr, HSTACK(qty, qty * uCost), SUM, , 0, , 0)
)
);
Filldownλ(init, list)
=SCAN(init, list, REPLACEBLANKλ);
May 27 2024 10:59 PM - edited May 28 2024 12:32 PM
Thanks a Lot Sir!
First of all, I must admire the elegancy with which you create these Dynamic Array Formulae. Just magic, to say the least. I have been trying to do some stuff myself but still find at loss to get a grip on the LAMBDA function. It seems I need to invest some serious time learning these DAFs.
I must admit that the solution is not best suited to the result I wanted. But it is definitely helping me in unentangling the LAMBDA mysteries. So, a BIG Thank You to you!
I am also trying to find something suitable for such scenarios, other than VBA solution, just in the pursuit of learning the DAF. Will definitely need your help in very near future.
Regards
Kanwaljit
Jul 04 2024 12:43 AM
@KanwalNo1 If you're still interested in a formula-based solution, @PeterBartholomew1 's method is the way to go (with a few minor tweaks). By using the row numbers of each dataset for the Input and Output IDs, as opposed to the dates, you can use the INDEX function to pull the necessary columns from the original dataset and, with a few additional steps, generate the desired results.
The core elements of the following formula were taken from Peter's custom FIFO functions and customized to meet your specific needs:
=LET(
FIFO, LAMBDA(inAmt,outAmt,
LET(
inRows, ROWS(inAmt) + 1,
outRows, ROWS(outAmt) + 1,
inRecords, HSTACK(EXPAND(SEQUENCE(inRows),, 2, ""), VSTACK(0, SCAN(0, inAmt, LAMBDA(a,v, a + v)))),
outRecords, CHOOSECOLS(HSTACK(EXPAND(SEQUENCE(outRows),, 2, ""), VSTACK(0, SCAN(0, outAmt, LAMBDA(a,v, a + v)))), 2, 1, 3),
unionAll, SORT(VSTACK(inRecords, outRecords), 3),
inId, SCAN(1, CHOOSECOLS(unionAll, 1), LAMBDA(a,v, IF(v = "", a, v))),
outId, SCAN(1, CHOOSECOLS(unionAll, 2), LAMBDA(a,v, IF(v = "", a, v))),
amt, CHOOSECOLS(unionAll, 3),
netAmt, VSTACK(DROP(amt, 1), TAKE(amt, -1)) - amt,
total, SCAN(0, netAmt, LAMBDA(a,v, a + v)),
FILTER(HSTACK(inId, outId, netAmt, total), (outId < outRows) * (netAmt <> 0))
)
),
chaData, SORT(FILTER(Challan, Challan[Amount] > 0), {1,3}),
recData, SORT(FILTER(Receipts, Receipts[Amount] > 0), {1,4,3}),
chaID, CHOOSECOLS(chaData, 1),
recID, CHOOSECOLS(recData, 1),
REDUCE(
{"ID","Party","Receipt Date","Amount","Tax Amt","Running Total","CIN","CIN Date"},
UNIQUE(recID),
LAMBDA(p,v,
LET(
cha, FILTER(chaData, chaID = v, EXPAND(v,, COLUMNS(chaData), 0)),
rec, FILTER(recData, recID = v),
output, FIFO(CHOOSECOLS(cha, 4), CHOOSECOLS(rec, 5)),
recOut, INDEX(rec, CHOOSECOLS(output, 2), {1,3,4}),
amount, CHOOSECOLS(output, 3),
taxAmt, ROUND(amount * 0.001, 0),
runTtl, CHOOSECOLS(output, 4),
cId, CHOOSECOLS(output, 1),
chaOut, IF(cId > ROWS(cha), {"Short",""}, INDEX(cha, cId, {2,3})),
VSTACK(p, HSTACK(recOut, amount, taxAmt, runTtl, chaOut))
)
)
)
)
This method is far more efficient than my previous attempts to iterate through the records with SCAN and LAMBDA recursion, which suffered from significant calculation lag after just 100-200 rows of receipts:
=LET(
cha, SORT(FILTER(Challan, Challan[Amount] > 0), {1,3}),
chaID, CHOOSECOLS(cha, 1),
chaAmt, CHOOSECOLS(cha, 4),
rws, ROWS(cha),
rec, SORT(FILTER(Receipts, Receipts[Amount] > 0), {1,4,3}),
recID, CHOOSECOLS(rec, 1),
recAmt, CHOOSECOLS(rec, 5),
FIFO, LAMBDA(ME,text,
LET(
p, TAKE(--TEXTSPLIT(text, "|"),, -6),
prr, INDEX(p, 1),
pra, INDEX(p, 2),
pcr, INDEX(p, 3),
pca, INDEX(p, 4),
pur, INDEX(p, 5),
rr, prr + NOT(pra),
ra, IF(pra, pra, INDEX(recAmt, rr)),
rId, INDEX(recID, rr),
new, OR(NOT(pca), rId <> IF(pcr, INDEX(chaID, pcr), "")),
cr, IF(new, IF(pur = rws, 0, IFNA(XMATCH(rId, DROP(chaID, pur)) + pur, 0)), pcr),
ca, IF(new, IF(cr, INDEX(chaAmt, cr), 0), pca),
amt, IF(ca, MIN(ra, ca), ra),
txt, IF(rr = prr, text & "|", "") & TEXTJOIN("|",, rr, ra - amt, cr, MAX(ca - amt, 0), MAX(cr, pur), amt),
IF(amt = ra, txt, ME(ME, txt))
)
),
TEXT2COLS, LAMBDA(array,delimiter,
LET(
arr, delimiter & array & delimiter,
cols, SEQUENCE(, MAX(LEN(arr) - LEN(SUBSTITUTE(arr, delimiter, ))) / LEN(delimiter) - 1),
TEXTBEFORE(TEXTAFTER(arr, delimiter, cols), delimiter)
)
),
results, SCAN(TEXTJOIN("|",, SEQUENCE(1,6,0,0)), SEQUENCE(ROWS(rec)), LAMBDA(a,v, FIFO(FIFO, a))),
output, WRAPROWS(--TOCOL(TEXT2COLS(results, "|"), 2), 6),
recOut, INDEX(rec, CHOOSECOLS(output, 1), {1,3,4}),
amount, CHOOSECOLS(output, 6),
taxAmt, ROUND(amount * 0.001, 0),
runTtl, --TEXTAFTER(SCAN("|", CHOOSECOLS(recOut, 1) & "|" & amount, LAMBDA(a,v, LET(
id, TEXTBEFORE(v, "|"),
amt, TEXTAFTER(v, "|"),
id & "|" & IF(id = TEXTBEFORE(a, "|"), TEXTAFTER(a, "|") + amt, amt)))), "|"),
cId, CHOOSECOLS(output, 3),
chaOut, IF(cId, INDEX(cha, cId, {2,3}), {"Short",""}),
HSTACK(recOut, amount, taxAmt, runTtl, chaOut)
)
Enjoy!
Jul 04 2024 01:17 AM
May 26 2024 08:01 PM - edited May 26 2024 08:15 PM
Solution@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!