عرض الاصناف الراكدة لكل مخزن

[mahmoud nasr alhasany]

السلام عليكم ورحمة تالله وبركاتة

الرجاء مساعدتى اذا سمحتم

يوجد شيت تجريبى نبذة للعمل المطلوب  اريد معرفة الاصناف الراكدة والمتحركة لكل مخزن كما هو موضح فى الكود

يوجد مشكلة فى الكود لعدم استعراض الاصناف الراكدة

وذلك من خلال صلاحية حركة المنتج والكمية

 

Sub FindStagnantItems()
    Dim ws As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, i As Long
    Dim item As String, category As String, lastMovementDate As Date
    Dim stagnantItemsByCategory As Object
    Dim warehouseNames As Variant
    Dim stagnantPeriod As Integer
    Dim totalStagnantItemsByCategory As Object

    ' تحديد الفترة التي تعتبر بعدها الصنف راكدًا
    stagnantPeriod = 90

    ' تحديد أسماء أوراق العمل التي تمثل المخازن
    warehouseNames = Array("مخزن الرئيسي", "فرع 1")

    ' إنشاء قاموس لتخزين الأصناف الراكدة حسب التصنيف
    Set stagnantItemsByCategory = CreateObject("Scripting.Dictionary")
    Set totalStagnantItemsByCategory = CreateObject("Scripting.Dictionary")
    ' تكرار العملية لكل مخزن
    For Each warehouseName In warehouseNames
        
        On Error Resume Next
Set ws = ThisWorkbook.Sheets(warehouseName)
If Err.Number <> 0 Then
    MsgBox "حدث خطأ في الوصول إلى ورقة العمل: " & Err.Description
    Exit Sub
End If
On Error GoTo 0
        
        
        lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

        ' البحث عن الأصناف الراكدة في المخزن الحالي
        For i = 2 To lastRow
            item = ws.Cells(i, 1).Value
            category = ws.Cells(i, 4).Value
            lastMovementDate = ws.Cells(i, 3).Value

            If DateDiff("d", lastMovementDate, Date) > stagnantPeriod Then
                If Not stagnantItemsByCategory.Exists(category) Then
                    stagnantItemsByCategory.Add category, New Collection
                End If
                stagnantItemsByCategory(category).Add item

                ' حساب إجمالي الأصناف الراكدة لكل تصنيف
                If Not totalStagnantItemsByCategory.Exists(category) Then
                    totalStagnantItemsByCategory.Add category, 1
                Else
                    totalStagnantItemsByCategory(category) = totalStagnantItemsByCategory(category) + 1
                End If
            End If
        Next i
    Next warehouseName

    ' إنشاء ورقة عمل جديدة لعرض النتائج
    Set wsOutput = Worksheets.Add
    wsOutput.Name = "أصناف راكدة"
    wsOutput.Range("A1").Value = "التصنيف"
    wsOutput.Range("B1").Value = "عدد الأصناف الراكدة"

    ' عرض النتائج
    Dim categoryName As Variant
    Dim currentRow As Long
    currentRow = 2
    For Each categoryName In totalStagnantItemsByCategory.Keys
        wsOutput.Cells(currentRow, 1).Value = categoryName
        wsOutput.Cells(currentRow, 2).Value = totalStagnantItemsByCategory(categoryName)
        currentRow = currentRow + 1
    Next categoryName
End Sub

 

الاصناف الراكدة لكل مخزن.xlsm

تم تعديل بالامس في 08:31 بواسطه mahmoud nasr alhasany

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

جرب هدا

Option Explicit
Sub FindStagnantItems()
    Const stagnantPeriod As Integer = 90
    Dim WS As Worksheet, dest As Worksheet, ShArr As Variant, Ky As Object
    Dim lastRow As Long, i As Long, d As Object, cate As Variant, Irow As Long
    Dim item As String, Store As String, Movement As Date, C As Variant
    
    ShArr = Array("مخزن الرئيسي", "فرع 1")
    Set d = CreateObject("Scripting.Dictionary"): Set Ky = CreateObject("Scripting.Dictionary")
    For Each C In ShArr
        On Error Resume Next
        Set WS = ThisWorkbook.Sheets(C)
        On Error GoTo 0
        
    If WS Is Nothing Then MsgBox "خطأ في الوصول إلى الورقة: " & C, vbCritical: Exit Sub
        Application.ScreenUpdating = False
        lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lastRow
    item = WS.Cells(i, 1).Value: Store = WS.Cells(i, 4).Value: Movement = WS.Cells(i, 3).Value
    If item <> "" And Store <> "" Then
        If IsDate(Movement) Then
            If DateDiff("d", Movement, Date) > stagnantPeriod Then
                If Not d.Exists(Store) Then d.Add Store, New Collection
                If Not n(d(Store), item) Then d(Store).Add item
                Ky(Store) = Ky(Store) + 1
             End If
           End If
        End If
      Next i
    Next C
    On Error Resume Next: Set dest = Worksheets("أصناف راكدة"): On Error GoTo 0
    If dest Is Nothing Then
        Set dest = Worksheets.Add: dest.Name = "أصناف راكدة"
    Else
        dest.Cells.ClearContents
    End If
    dest.[A1].Resize(1, 2) = Array("التصنيف", "عدد الأصناف الراكدة")
    Irow = 2
    For Each cate In Ky.keys
        dest.Cells(Irow, 1).Value = cate
        dest.Cells(Irow, 2).Value = Ky(cate)
        Irow = Irow + 1
    Next cate
    Application.ScreenUpdating = True
    MsgBox "تم إنشاء تقرير الأصناف الراكدة بنجاح", vbInformation
End Sub
Function n(col As Collection, val As String) As Boolean
    On Error Resume Next
    n = Not IsError(col(val))
End Function

 

 

الاصناف الراكدة لكل مخزن.xlsm

تم تعديل منذ 8 ساعات بواسطه محمد هشام.

[mahmoud nasr alhasany]

الف شكر ا/ محمد هشام

للمساعدة

هل يمكن اضافة وارفاق كود واسم الصنف والكمية مع التقرير اى البيانات الليس عليها  اى حركة او حركتها ضعيفة نسبة للكمية والصلاحية

الاصناف الراكدة لكل مخزن(1).xlsm

تم تعديل منذ 2 ساعات بواسطه mahmoud nasr alhasany

[mahmoud nasr alhasany]

الاصناف الراكدة لكل مخزن(1) - Copy.xlsm