Closing Stock Report With Parameters

[Prabhu]

Hi Friends,

I needs to Identify the Closing stock based on part numbers from the Purchase and sales transactions .

And then i need to identify the closing stock which is lying over 60 days in the inventory.

Example:

I purchased Part number "XYZ' 70 Nos on 1of Jan'11and 30 Nos on 15th of Feb'11
Sold 60 till 31st march '11 and balance 40 nos on 31st March 2011. In that 40 Nos 10 nos over 60 days stock

I have attached sheet which contains purchase and sales sheet with Summary which we needs to prepare.
I have taken 3rd Sep 2011 is Base date in this working.

can anybody help to get VBA code for preparing Summary sheet!

Pzl revert back if you have any doubt on this.

Regards,

Prabhu

[Admin]

Hi Prabhu,

Try this one.


Option Explicit

Sub kTest()

Dim wksPurch As Worksheet, wksSales As Worksheet, dtCurrent As Date
Dim ka, k(), i As Long, n As Long, t(), wksSummary As Worksheet

Set wksPurch = Worksheets("Purchase")
Set wksSales = Worksheets("Sales")
Set wksSummary = Worksheets("Summary")

i = wksPurch.UsedRange.Rows.Count + wksSales.UsedRange.Rows.Count
ReDim k(1 To i, 1 To 6)

With CreateObject("scripting.dictionary")
.comparemode = 1
dtCurrent = wksPurch.Range("b1")
ka = wksPurch.Range("a1").CurrentRegion.Resize(, 5).Offset(1)
For i = 2 To UBound(ka, 1)
If Len(ka(i, 1)) * Len(ka(i, 3)) Then
If Not .exists(Trim$(ka(i, 1))) Then
n = n + 1
k(n, 1) = Trim$(ka(i, 1))
k(n, 2) = ka(i, 4)
If dtCurrent - CDate(ka(i, 3)) > 60 Then k(n, 5) = ka(i, 4)
k(n, 4) = "=RC[-2]-RC[-1]"
k(n, 6) = "=RC[-2]-RC[-1]"
.Add Trim$(ka(i, 1)), Array(n, 6)
Else
t = .Item(Trim$(ka(i, 1)))
k(t(0), 2) = k(t(0), 2) + ka(i, 4)
If dtCurrent - CDate(ka(i, 3)) > 60 Then
k(t(0), 5) = k(t(0), 5) + ka(i, 4)
End If
End If
End If
Next
ka = wksSales.Range("a1").CurrentRegion.Resize(, 5)
For i = 2 To UBound(ka, 1)
If Len(ka(i, 1)) * Len(ka(i, 3)) Then
If .exists(Trim$(ka(i, 1))) Then
t = .Item(Trim$(ka(i, 1)))
k(t(0), 3) = k(t(0), 3) + ka(i, 4)
k(t(0), 5) = Application.Max(0, k(t(0), 5) - ka(i, 4))
End If
End If
Next
End With
If n Then
With wksSummary
.Range("a2").Resize(n, 6).Value = k
End With
End If

End Sub

[littleiitin]

Try Below code:




Sub DetailedSumary()

Dim strSheetName As String
Dim rngSumCell As Range
Dim rngPurCell As Range
Dim rngSellCell As Range
With ThisWorkbook.Worksheets("Purchase")
.Range("A3:A" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
End With
Sheets.Add After:=Sheets(Sheets.Count)
strSheetName = ActiveSheet.Name
With ThisWorkbook.Worksheets(strSheetName)
.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
.Range("$A$1:$A" & .Range("A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
.Range("$A$1:$A" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
End With

With ThisWorkbook.Worksheets("Summary")
.Range("A2").PasteSpecial xlPasteValues
End With
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(strSheetName).Delete
Application.DisplayAlerts = True

Dim lngMorethan60DaysPur As Long
Dim lngTotalPur As Long
Dim lngTotalSal As Long
Dim j As Long
Dim k As Long
With ThisWorkbook.Worksheets("Summary")
.Range("A1").CurrentRegion.Offset(1, 1).ClearContents
For Each rngSumCell In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row + 1)
For Each rngPurCell In ThisWorkbook.Worksheets("Purchase").Range("A3:A" & ThisWorkbook.Worksheets("Purchase").Range("A" & Rows.Count).End(xlUp).Row + 1)
If rngPurCell.Value = rngSumCell.Value Then
j = 1
If Now() - rngPurCell.Offset(, 2) >= 60 Then
lngMorethan60DaysPur = lngMorethan60DaysPur + rngPurCell.Offset(, 3)
End If
lngTotalPur = lngTotalPur + rngPurCell.Offset(, 3)
ElseIf rngPurCell.Value <> rngSumCell.Value And j = 1 Then
rngSumCell.Offset(, 1) = lngTotalPur
rngSumCell.Offset(, 6) = lngMorethan60DaysPur
lngTotalPur = 0
lngMorethan60DaysPur = 0
j = 0
GoTo Sale:
End If
Next rngPurCell
Sale:
For Each rngSellCell In ThisWorkbook.Worksheets("Sales").Range("A2:A" & ThisWorkbook.Worksheets("Sales").Range("A" & Rows.Count).End(xlUp).Row + 1)
If rngSellCell.Value = rngSumCell.Value Then
lngTotalSal = lngTotalSal + rngSellCell.Offset(, 3)
k = 1
ElseIf rngSellCell.Value <> rngSumCell.Value And k = 1 Then
rngSumCell.Offset(, 2) = lngTotalSal
lngTotalSal = 0
k = 0
GoTo Purchase:
End If
Next rngSellCell
Purchase:
Next rngSumCell

For Each rngSumCell In .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)

If rngSumCell.Offset(, 1) - rngSumCell.Offset(, 2) > 0 Then
rngSumCell.Offset(, 3) = rngSumCell.Offset(, 1) - rngSumCell.Offset(, 2)
Else
rngSumCell.Offset(, 3) = 0
End If

If rngSumCell.Offset(, 6) - rngSumCell.Offset(, 2) > 0 Then
rngSumCell.Offset(, 4) = rngSumCell.Offset(, 6) - rngSumCell.Offset(, 2)
Else
rngSumCell.Offset(, 4) = ""
End If
rngSumCell.Offset(, 6) = ""
If rngSumCell.Offset(, 3) - rngSumCell.Offset(, 4) > 0 Then
rngSumCell.Offset(, 5) = rngSumCell.Offset(, 3) - rngSumCell.Offset(, 4)
Else
rngSumCell.Offset(, 5) = 0
End If
Next


End With



End Sub

[Prabhu]

:)Hi Friends,

Thanks a lot!!! it is working fine.

Regards,

Prabhu

[Admin]

Prabhu,

You are welcome !!

Thanks for the feedback :cheers:

[Prabhu]

Hi Friends,

Am using the attached macro(shared by Admin)whis is working fine.And now i need a small modification int he existing macro(Sheet attached).

Se needs to add GROUP infornt of part number. Same part number may have differnent grup.

we have to calculate Closingstock on the basis of Grup wise then part number wise.


I have attached sample date.Kindly help with the modification inthe existing macro in the same excel itself.

Regards,

Prabhu

[Admin]

Hi

Put the code in standard module.


Sub kTest_v1()

Dim wksPurch As Worksheet, wksSales As Worksheet, dtCurrent As Date
Dim ka, k(), i As Long, n As Long, t(), wksSummary As Worksheet
Dim Concat As String

Set wksPurch = Worksheets("Purchase")
Set wksSales = Worksheets("Sales")
Set wksSummary = Worksheets("Summary")

i = wksPurch.UsedRange.Rows.Count + wksSales.UsedRange.Rows.Count
ReDim k(1 To i, 1 To 7)

With CreateObject("scripting.dictionary")
.comparemode = 1
dtCurrent = wksPurch.Range("b1")
ka = wksPurch.Range("a1").CurrentRegion.Resize(, 6).Offset(1)
For i = 2 To UBound(ka, 1)
If Len(ka(i, 1)) * Len(ka(i, 2)) * Len(ka(i, 3)) Then
Concat = Trim$(ka(i, 1) & "|" & ka(i, 2))
If Not .exists(Concat) Then
n = n + 1
k(n, 1) = Trim$(ka(i, 1))
k(n, 2) = Trim$(ka(i, 2))
k(n, 3) = ka(i, 5)
If dtCurrent - CDate(ka(i, 4)) > 60 Then k(n, 6) = ka(i, 5)
k(n, 5) = "=RC[-2]-RC[-1]"
k(n, 7) = "=RC[-2]-RC[-1]"
.Add Concat, Array(n, 7)
Else
t = .Item(Concat)
k(t(0), 3) = k(t(0), 3) + ka(i, 5)
If dtCurrent - CDate(ka(i, 4)) > 60 Then
k(t(0), 6) = k(t(0), 6) + ka(i, 5)
End If
End If
End If
Next
ka = wksSales.Range("a1").CurrentRegion.Resize(, 6)
For i = 2 To UBound(ka, 1)
If Len(ka(i, 1)) * Len(ka(i, 2)) * Len(ka(i, 3)) Then
Concat = Trim$(ka(i, 1) & "|" & ka(i, 2))
If .exists(Concat) Then
t = .Item(Concat)
k(t(0), 4) = k(t(0), 4) + ka(i, 5)
k(t(0), 6) = Application.Max(0, k(t(0), 6) - ka(i, 5))
End If
End If
Next
End With
If n Then
With wksSummary
.Range("a2").Resize(n, 7).Value = k
End With
End If

End Sub

HTH

[Prabhu]

Thank you so much!!!

[Admin]

Hi Prabhu,

THanks for the feedback :cheers:

PLease share this forum among your friends :)