Forum Discussion

KanwalNo1's avatar
KanwalNo1
Iron Contributor
May 25, 2024

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...
  • djclements's avatar
    djclements
    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!

Resources