Closing Stock Report With Parameters

**Prabhu** · 09-04-2011, 09:32 PM

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** · 09-05-2011, 11:36 AM

Hi Prabhu,

Try this one.

Code:

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** · 09-05-2011, 11:37 AM

Try Below code:

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** · 09-06-2011, 09:32 PM

Hi Friends,

Thanks a lot!!! it is working fine.

Regards,

Prabhu

**Admin** · 09-06-2011, 09:44 PM

Prabhu,

You are welcome !!

Thanks for the feedback

**Prabhu** · 05-08-2012, 10:28 AM

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** · 05-08-2012, 12:23 PM

Hi

Put the code in standard module.

Code:

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