MATCH AMOUNT FIFO METHOD & INSERT ROWS WHERE EVER REQUIRED.

[Eddy Stan]

I have a spreadsheet having two ranges (1) deduction range (2) remittance range
since remittance is not made correctly I need to match remitance to
deduction range (FIFO method) and insert a row in the deduction range, if
required. sample as follows. ie c1 the first remittance is Rs 200 to be
matched with ded (d1 to d4), but for d4 is short by 50 which will be matched
with c2 remittance. similarly c2 Rs 300 will be matched with d4 to d6 and
short will be matched by c3, like wise.
DEDUCTION RANGE
MONTH DED REF DED REMIT REF MATCHED REMIT AMT
JAN D1 25 C1 25
JAN D2 50 C1 50
JAN D3 75 C1 75
JAN D4 100 C1 50
JAN D4 C2 50
FEB D5 125 C2 125
FEB D6 150 C2 125
FEB D6 C3 25
FEB D7 175 C3 175
MAR D8 200 C3 200

REMITANCE RANGE
S No REMIT REF REMIT AMT
1 C1 200
2 C2 300
3 C3 400

I have approx.6000 rows to match for 375 rows

Thanks in advance.

 

[Eddy Stan]

Hi Wizards there,
I need code to update in "deduction range" under column "Remit Ref" &
"matched remit amount" comparing "Remittance Range".

 

[Toppers]

Hi,
Try this. You need to change sheet names and possibly ranges to suit.
I have assumed DEDUCTION range is columns A To E and Remitance A to B; the
latter may need to changed to B to C if "S No" is in column A.

Sub a()

Dim rngd As Range, rnga As Range
Dim lastrow As Long
Dim n As Integer
Dim remitAmount As Double, Deduction As Double
' Remitance Range
With Worksheets("Sheet3")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rnga = .Range("A1:B" & lastrow) '<=== may need to be B and C
End With
' Deduction range (sheet)
With Worksheets("Sheet2")

lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
Set rngd = .Range("d1:d" & lastrow)
r = 2
Deduction = 0

Do
n = Application.CountIf(rngd, .Cells(r, "D"))
Deduction = Deduction + Application.Sum(Range("C" & r & ":C" & r + n
- 1))
remitAmount = Application.VLookup(.Cells(r, "D"), rnga, 2, False)
If remitAmount < Deduction Then
.Cells(r + n, "A").EntireRow.Insert shift:=xlDown
.Cells(r + n - 1, "A").Resize(1, 5).Copy .Cells(r + n, "A")
.Cells(r + n, "E") = Deduction - remitAmount
.Cells(r + n, "D") = .Cells(r + n + 1, "D")
.Cells(r + n, "C") = ""
Deduction = .Cells(r + n, "E")
lastrow = lastrow + 1
End If
r = r + n
Loop Until r >= lastrow

End With

End Sub


HTH

 

[Toppers]

Updated version:

Sub x()

Dim rngd As Range, rnga As Range
Dim lastrow As Long
Dim n As Integer
Dim remitAmount As Double, Deduction As Double
' Remitance Range
With Worksheets("Sheet2")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rnga = .Range("B1:C" & lastrow)
End With
' Deduction range (sheet)
With Worksheets("Sheet1")

lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
Set rngd = .Range("d1:d" & lastrow)
r = 2
Deduction = 0

Do
n = Application.CountIf(rngd, .Cells(r, "D"))
remitAmount = Application.VLookup(.Cells(r, "D"), rnga, 2, False)
For Row = r To r + n - 1
If .Cells(Row, "C") > 0 Then
If remitAmount >= .Cells(Row, "C") Then
.Cells(Row, "E") = .Cells(Row, "C")
remitAmount = remitAmount - .Cells(Row, "C")
Else
.Cells(Row, "E") = remitAmount
.Cells(r + n, "A").EntireRow.Insert shift:=xlDown
.Cells(r + n - 1, "A").Resize(1, 5).Copy .Cells(r + n, "A")
.Cells(r + n, "E") = .Cells(Row, "C") - remitAmount
.Cells(r + n, "D") = .Cells(r + n + 1, "D")
.Cells(r + n, "C") = ""
lastrow = lastrow + 1
End If
Else
remitAmount = remitAmount - .Cells(Row, "E")
End If
Next Row
r = r + n
Loop Until r >= lastrow

End With

End Sub

 

[Eddy Stan]

Hi Toppers,
The revised version worked for me, but now my manager has slightly changed
his request.
Change is as follows: ..that is
(1) in sheet2: insert row when the balance is there to adjust (do not adjust
to next), put the balance to adjust at F column (fill remit ref at D
(2) in sheet3: Put unallocated remittance next to remittance amount col d
THANKS IN ADVANCE

 

[Toppers]

Hi,
Can you post a example of the new layout using your original data to
ensure I understand it correctly.

Is it like this?

MONTH DED REF DED REMIT REF MATCHED REMIT AMT
JAN D1 25 C1 25
JAN D2 50 C1 50
JAN D3 75 C1 75
JAN D4 100 C1 50
JAN D4 C1 50 '<== Column F
FEB D5 125 C2 125
FEB D6 150 C2 125
FEB D6 C2 25 '<== Column F
FEB D7 175 C3 175
MAR D8 200 C3 200

 

[Toppers]

Eddy,
Hope this meets your requirements:

Dim rngd As Range, rnga As Range
Dim lastrow As Long
Dim n As Integer
Dim remitAmount As Double, Deduction As Double
' Remitance Range
With Worksheets("Sheet2")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rnga = .Range("B1:C" & lastrow)
End With
' Deduction range (sheet)
With Worksheets("Sheet1")

lastrow = .Cells(Rows.Count, "D").End(xlUp).Row
Set rngd = .Range("d1:d" & lastrow)
r = 2
Deduction = 0

Do
n = Application.CountIf(rngd, .Cells(r, "D"))
remitAmount = Application.VLookup(.Cells(r, "D"), rnga, 2, False)

For Row = r To r + n - 1
If remitAmount >= .Cells(Row, "C") Then
.Cells(Row, "E") = .Cells(Row, "C")
remitAmount = remitAmount - .Cells(Row, "C")
Else
.Cells(Row, "E") = .Cells(Row, "C") - remitAmount
End If
Next Row

' Any outstanding balance ? .....
If remitAmount > 0 Then
.Cells(r + n, "A").EntireRow.Insert shift:=xlDown
.Cells(r + n, "F") = remitAmount
.Cells(r + n, "D") = .Cells(r, "D")
Row = Application.Match(.Cells(r, "D"), rnga.Columns(1), 0)
Worksheets("Sheet2").Cells(Row, "D") = remitAmount
lastrow = lastrow + 1
End If

r = r + n + 1

Loop Until r >= lastrow

End With

 

[Eddy Stan]

Hi Toppers,
The code worked so good & fantastic.
This discussion forum is so meaningful & helpful.
Thanks with high regards to you.
Always
Eddy Stan