Allocating / Apportioning Challan Amounts to Different Receipts

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!