المرجوا من الإخوان الكرام مساعدتي

[سمير الليل]

المرجوا  من الإخوان الكرام مساعدتي
الصفحة الأولى بها جدول بيانات موظفين
أريد اختيار  حسب إرادتي مجموعة من الموظفين مثلا
ليظهرو  لي في الصفحي الثانية 

(أي بمعني يظهر فقط الموظفين الذين اخترت)

 

smr.xlsx

[محمد هشام.]

ممكن توضح ما هي طريقة الاختيار المطلوبة 

[سمير الليل]

الاختيار حسب رقم  DRPP

مثلا اكتب مجموعة من ارقام   DRPP المراد اختيارهم في خانة ما

merci

[محمد هشام.]

تفضل جرب هدا 

Public Sub Filter_data()
Dim arrayCriteria(), _
          desWS As Worksheet, _
       lo As ListObject, _
    rng As Range, _
Cpt As Long, _
i As Long

    Set lo = Range("Clé").ListObject
    Cpt = lo.ListRows.Count
    ReDim arrayCriteria(Cpt)
    For i = 1 To Cpt
       arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1))
    Next i
    Set rng = Range("T_data"): Set desWS = Sheets("Feuil2")
 If WorksheetFunction.CountA(lo.DataBodyRange) = 0 Then MsgBox "المرجوا ادخال معيار الفلترة": Exit Sub

 With rng.ListObject
    Application.ScreenUpdating = False
        If .ShowAutoFilter Then .AutoFilter.ShowAllData
        .Range.AutoFilter field:=5, Criteria1:=arrayCriteria, Operator:=xlFilterValues
            If (rng.Rows.Count > 1) Then
            
         desWS.Range("d13:k" & Rows.Count).Clear
        .AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy desWS.[D13]
 
         [T_data].AutoFilter
      End If
    End With
    Application.ScreenUpdating = True

 

 

 

 

smr.xlsm

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

[سمير الليل]

شكرا لك أخي الكريم
الله يجازيك

 

تم تعديل مايو 6 بواسطه سمير الليل

[محمد هشام.]

العفو اخي يسعدنا اننا استطعنا مساعدتك 

اليك حل اخر في حالة الرغبة في عدم استخدام الجداول المحورية 

Sub FiltreListe()
Dim srcWS, rCrit, Irow As Long, _
                    WS As Worksheet, _
                desWS As Worksheet, _
             ColLast As Long, _
        rngFilter As Range, _
    i As Long: Cpt = 5: Set WS = Sheets("Feuil1"): Set desWS = Sheets("Feuil2")

  
Irow = WS.Columns("F:F").Find(What:="*", SearchDirection:=xlPrevious, _
                                          SearchOrder:=xlByRows).Row
Set rCrit = desWS.[A2:A10]: arr = rCrit.Value
  srcWS = WorksheetFunction.CountA(desWS.Range("a2:a" & desWS.Rows.Count))

Dim b(): ReDim b(0 To UBound(arr))
   On Error Resume Next
   For i = 0 To UBound(arr)
   If arr(i, 1) <> "" Then b(i) = CStr(arr(i, 1))
 Next i
  
 If srcWS = 0 Then MsgBox "المرجوا ادخال عناصر الفلترة" _
          & "", vbInformation, "انتباه": Exit Sub
          
        ColLast = WS.Cells(1, Columns.Count).End(xlToLeft).Column
        Set rngFilter = WS.Range(WS.Cells(1, "A"), WS.Cells(1, "H"))
    
'OR  Until the last column
       'Set rngFilter = WS.Range(WS.Cells(1, "A"), WS.Cells(Irow, ColLast))

 With rngFilter
  If .AutoFilterMode Then .AutoFilterMode = False
        .AutoFilter Field:=Cpt, Criteria1:=b, _
                       Operator:=xlFilterValues
                       
 j = Application.WorksheetFunction.Subtotal(3, WS.Range("F2:F" & Irow))
               
   If j = 0 Then: MsgBox "لا توجد بيانات ", vbInformation, "تم إلغاء الإجراء": .AutoFilter: Exit Sub

        desWS.Range("D13:K" & desWS.Rows.Count).Clear
        WS.AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy desWS.[D13]
      .AutoFilter
    End With
End Sub

 

smr V2.xlsm

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

[سمير الليل]

غيرت عمود الفلتر و لم يعد يعل الكود بشكل جيد
شركا أخي الكريم

smr.xlsm

[محمد هشام.]

4 ساعات مضت, سمير الليل said:

غيرت عمود الفلتر و لم يعد يعل الكود بشكل جيد

مادا غيرت اخي ممكن توضح اكثر لكي يتم تعديل الكود بما يناسبك