طلب مساعدة في كود للانتقال وتصفية البيانات في ورقة اخرى

[الو11111في]

في البداية كل الشكر والتقدير والامتنان للقائمين على هذا الصرح المميز  من مشرفين وخبراء واعضاء، فــ لهم منا كل الدعاء بالتوفيق والسعادة.

احتاج مساعدة في ادراج كود يقوم  عند الضغط على  كلمة  (تحت الاجراء )  في ورقة (لوحة المعلومات) بالانتقال الى ورقة( الرئيسية)  ويعمل تصفية على العمود ( J  )  لتظهر فقط الصفوف ذات قيمة تحت الاجراء.  كما يظهر الشرح في الملف المرفق 

 

واكرر الشكر والعرفان الجزيل 

ملف ادارة طلبات.xlsx

[محمد هشام.]

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

جرب هدا

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim WS As Worksheet, f As Worksheet
    Dim r As Range, DataRng As Range
    If Not Intersect(Target, Me.Range("C17")) Is Nothing Then
        Set WS = Sheets("الرئيسية")
        Set f = Sheets("لوحة المعلومات")
        WS.Activate
        If WS.AutoFilterMode Then
            WS.AutoFilterMode = False
        End If
        
        Set DataRng = WS.Range("A1").CurrentRegion
        
        With DataRng
            .AutoFilter Field:=10, Criteria1:="تحت الاجراء"
        End With
        
        On Error Resume Next
        Set r = WS.Range("J:J").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If r Is Nothing Then
            MsgBox "لم يتم العثور على أي صفوف تحتوي على تحت الاجراء", vbInformation
            WS.AutoFilterMode = False
        End If
        Application.Goto WS.Range("J3")
    End If
End Sub

 

[عبدالله بشير عبدالله]

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

بعد اذن استاذنا الفاضل  محمد هشام ,حل لكل الخيارات وان لم يطلبها صاحب الموضوع

الكود

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim wsDashboard As Worksheet
    Dim wsMain As Worksheet
    Dim rng As Range
    Dim count As Long
    Dim filterValue As String

    Set wsDashboard = ThisWorkbook.Sheets("لوحة المعلومات")
    Set wsMain = ThisWorkbook.Sheets("الرئيسية")

    Select Case Target.Address
        Case wsDashboard.Range("C17").Address
            filterValue = "تحت الاجراء"
        Case wsDashboard.Range("D17").Address
            filterValue = "في الانتظار"
        Case wsDashboard.Range("F17").Address
            filterValue = "مكتمل"
        Case wsDashboard.Range("G17").Address
            filterValue = "محالة"
        Case wsDashboard.Range("H17").Address
            filterValue = "معلق / مؤجل"
        Case Else
            Exit Sub
    End Select

    wsMain.Activate

    If wsMain.AutoFilterMode Then
        wsMain.AutoFilterMode = False
    End If

    wsMain.Range("A1").AutoFilter Field:=10, Criteria1:=filterValue

    Set rng = wsMain.Range("J2:J" & wsMain.Cells(wsMain.Rows.count, "J").End(xlUp).Row)
    count = Application.WorksheetFunction.CountIf(rng, filterValue)

    If count > 0 Then
        MsgBox "عدد الطلبات التي تحتوي على '" & filterValue & "' هو: " & count
    Else
        MsgBox "لا توجد طلبات تحتوي على '" & filterValue & "'."
    End If
End Sub

الملف

 

ملف ادارة طلبات1.xlsb

[محمد هشام.]

1 ساعه مضت, عبدالله بشير عبدالله said:

بعد اذن استاذنا الفاضل  محمد هشام ,حل لكل الخيارات وان لم يطلبها صاحب الموضوع

بارك الله فيك اخي @عبدالله بشير عبدالله  

نعم يمكننا إظافة شروط أخرى بطريقة مختصرة وبدون تقييد للمعايير فقط يكفي الإشارة على عناوين خلايا تنفيد الكود  مع  تعديل طريقة الفلترة  لنتمكن من التحقق من وجود بيانات مطابقة قبل الانتقال لورقة  لوحة المعلومات وفلترة البيانات 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCrit As String, Lr As Long
    Dim OneRng As Variant, i As Long, cnt As Boolean
    Dim f As Worksheet: Set f = Sheets("الرئيسية")

    If Not Intersect(Target, Me.Range("B17, C17, D17, E17, F17, G17")) Is Nothing Then
        rCrit = Target.Value
        If rCrit = "" Then Exit Sub

        If f.AutoFilterMode Then f.AutoFilterMode = False
        Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row

           OneRng = f.Range("J2:J" & Lr).Value
            For i = 1 To UBound(OneRng, 1)
                If OneRng(i, 1) = rCrit Then: cnt = True: Exit For
            Next i
        If cnt Then
                f.Activate
         With f.Range("B2:L" & Lr)
                .AutoFilter 9, rCrit
            End With
        Application.Goto f.Range("J2")
          Else
        MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة"
      End If
    End If
End Sub

كما يمكننا كدالك استخدام مصفوفة (Array) لتحديد مجموعة  من الخلايا  بدلاً من تحديدها بشكل مباشر 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rCrit As String, Lr As Long, n As Boolean, ColArray As Variant
    Dim OneRng As Variant, i As Long, cnt As Boolean
    
    Dim f As Worksheet: Set f = Sheets("الرئيسية")
    ColArray = Array("B17", "C17", "D17", "E17", "F17", "G17")
    
    For i = LBound(ColArray) To UBound(ColArray)
       If Not Intersect(Target, Me.Range(ColArray(i))) Is Nothing Then
            n = True
            Exit For
        End If
    Next i
        If n Then
        rCrit = Target.Value
        If rCrit = "" Then Exit Sub
        
        If f.AutoFilterMode Then f.AutoFilterMode = False
        Lr = f.Cells(f.Rows.count, "J").End(xlUp).Row
        
        OneRng = f.Range("J2:J" & Lr).Value
        For i = 1 To UBound(OneRng, 1)
            If OneRng(i, 1) = rCrit Then: cnt = True: Exit For
        Next i
        
     If cnt Then
            f.Activate
            With f.Range("B2:L" & Lr)
                .AutoFilter 9, rCrit
            End With
            Application.Goto f.Range("J2")
        Else
       MsgBox "قاعدة البيانات لا تتضمن معاملات من نوع " & rCrit, vbInformation, "نتيجة الفلترة"
        End If
    End If
End Sub

 

ملف ادارة طلبات.xlsb

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

[عبدالله بشير عبدالله]

بارك الله فيك  استاذنا الفاضل محمد هشام  على الافادة (وَقُل رَّبِّ زِدْنِي عِلْمًا)

[الو11111في]

م. محمد هشام

م. عبدالله بشير

بارك الله فيكما ونفع بعلمكما وكتب الله لكم الاجر والثواب

 

كل الشكر والاحترام والتقدير على جهودكم ودعمكم اللامحدود