الرجاء المساعدة في ملف الجرد

[spyhearts]

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

اسعد الله اوقاتاكم اعضاء المنتدى العريق

امل المساعد في الملف المرفق لعمل جرد بالمنتج والموقع

ولكم جزيل الشكر

جرد المنتج.xlsb

[محمد هشام.]

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

ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض 

ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب 

في  Module1 ضع الأكواد التالية

Const a As String = "الرئيسية"
Const b As String = "تقرير بالموقع"
Const c As String = "تقرير بالمنتج"
Public Property Get WS() As Worksheet
    Set WS = Sheets(a)
End Property
Public Property Get dest() As Worksheet
    Set dest = Sheets(b)
End Property
Public Property Get dest2() As Worksheet
    Set dest2 = Sheets(c)
End Property
Sub Run_MainFilter()
    Call FilterData("J", dest, dest.Range("B2"))
    Call ApplyBorders(ActiveSheet)
End Sub
Sub Run_SecondaryFilter()
    Call FilterData("D", dest2, dest2.Range("B2"))
    Call ApplyBorders(ActiveSheet)
End Sub
'   دالة لفلترة البيانات 
Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range)
    Dim arr() As Variant, dataRange As Range, lastRow As Long
    Dim Crite As String, ColArr As Long, N As Long, lastCol As Long
    
    Crite = Clé.Value
    lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row

    If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _
    LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        MsgBox Crite & " غير موجود", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False
    
    srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents

    arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value
    N = 5

    For ColArr = 1 To UBound(arr, 1)
        If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then
            srsWS.Cells(N, 1).Resize(1, 10).Value _
            = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11))
            N = N + 1
        End If
    Next ColArr

    lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column
    lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row

    srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address

    Application.ScreenUpdating = True
End Sub

' تعبئة القائمة المنسدلة تقرير المنتج
Sub AddDropdown_Main()
    Dim Data As Range, destCell As Range
    Dim lastRow As Long, OnRng As String

    OnRng = "Dropdown_Main"
    Set destCell = dest.Range("B2")
    lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row
    Set Data = WS.Range("P2:P" & lastRow)

    On Error Resume Next
    ThisWorkbook.Names(OnRng).Delete
    On Error GoTo 0

    ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data

    With destCell.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="=" & OnRng
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
End Sub

'  تعبئة القائمة المنسدلة تفرير بالموقع 
Sub AddDropdown_Secondary()
    Dim Data As Range, destCell As Range
    Dim lastRow As Long, OnRng As String

    OnRng = "Dropdown_Secondary"
    Set destCell = dest2.Range("B2")
    lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row
    Set Data = WS.Range("O2:O" & lastRow)

    On Error Resume Next
    ThisWorkbook.Names(OnRng).Delete
    On Error GoTo 0

    ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data

    With destCell.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="=" & OnRng
        .IgnoreBlank = True
        .InCellDropdown = True
    End With
End Sub
' تسطير البيانات 
Sub ApplyBorders(wsTarget As Worksheet)
    Dim lastRow As Long, rng As Range
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    If lastRow < 5 Then Exit Sub
    Application.ScreenUpdating = False
    wsTarget.Range("A5:J100").Borders.LineStyle = xlNone
    Set rng = wsTarget.Range("A5:J" & lastRow)

    With rng.Borders
        .LineStyle = xlContinuous
        .Color = RGB(0, 0, 0)
        .Weight = xlThin
    End With
    Application.ScreenUpdating = True
End Sub

وفي حدث ورقة الرئيسية 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range
    Dim LastRow As Long
    
    Application.ScreenUpdating = False

    If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _
       Not Intersect(Target, Me.Columns("J")) Is Nothing Then

        If Not Intersect(Target, Me.Columns("D")) Is Nothing Then
            Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp))
            Set OnRng = Me.Range("O2:O65000")
        Else
            Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp))
            Set OnRng = Me.Range("P2:P65000")
        End If
        
        Set tmp = CreateObject("Scripting.Dictionary")
        For Each item In ColArr
            If item.Value <> "" Then tmp(item.Value) = ""
        Next item
        
        OnRng.ClearContents
        If tmp.Count > 0 Then
            OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys)
        End If
    End If
    
    Application.ScreenUpdating = True
End Sub

في حدث ورقة تقرير بالموقع

Private Sub CommandButton1_Click()
Call SaveRangeAsPDF
End Sub
Private Sub Worksheet_Activate()
Call AddDropdown_Secondary
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
    If Me.Range("B2").Value = "" Then _
    MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub
     Call Run_SecondaryFilter
  End If
End Sub

وفي حدث ورقة تقرير بالمنتج 

Private Sub CommandButton1_Click()
Call SaveRangeAsPDF
End Sub
Private Sub Worksheet_Activate()
Call AddDropdown_Main
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
    If Me.Range("B2").Value = "" Then _
    MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub
     Call Run_MainFilter
  End If
End Sub

وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF

Option Explicit
Sub SaveRangeAsPDF()
    Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String
    Dim lastRow As Long, lastCol As Long, pdfPath As String
    
    Set WSdest = ActiveSheet
    sFile = WSdest.Name
    folderName = "ملفات PDF"
    sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator

    On Error Resume Next
    If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath
    On Error GoTo 0

    lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row
    lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column
    WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address

    With WSdest.PageSetup
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
        pdfPath = sPath & sFile & ".pdf"
        WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard
        MsgBox "تم حفظ الملف بنجاح", vbInformation
    End Sub

بالتوفيق ............

 

 

جرد المنتج_V2.xlsb

تم تعديل نوفمبر 20 بواسطه محمد هشام.

[spyhearts]

شكرا لحضرتك ا. محمد على مجهودك جزاك الله كل خير 

عمل رائع ربنا يزيدك من علمه