SOLVED

Allocating / Apportioning Challan Amounts to Different Receipts

Iron Contributor

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

@Sergei Baklan

@Peter Bartholomew

@lori_m

@Chris_Gross

and to all the Esteemed Experts

12 Replies

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

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!

@djclements

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

best response confirmed by KanwalNo1 (Iron Contributor)
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!

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

https://techcommunity.microsoft.com/t5/excel/allocating-apportioning-challan-amounts-to-different-re...

 

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

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

Heartily Appreciated!
No words are enough to convey my appreciation!
MAY the Almighty Bless you with Health and Happiness !

@KanwalNo1 

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.

 

Image and formula:

image.png

= 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λ);

 

@PeterBartholomew1 

 

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

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

@djclements People like you make our planet worth living.
I had even forgotten about the DAF solution myself. You remembered! Thanks for being here. Words are not enough to appreciate the sincerity and dedication. I will have a thorough look into the same.

But I must admit that I am worried for you now. You possess the same traits which also made me lose my sleep over things which appealed to my mind in a challenging way. Started to lose my health. Long hours of sitting without even noticing the eatables lying beside me. If you do something like this, please don't do it. Please take very good care of you! Please! Please! Please!
1 best response

Accepted Solutions
best response confirmed by KanwalNo1 (Iron Contributor)
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!

View solution in original post