كود فلترة

[2saad]

اخواني اعضاء المنتدي الكرام السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير 

محتاج كود فلترة من شيت 1 الي شيت 2 بناء علي القائمة المنسدلة الملونة باللون الأصفر في شيت 2

ابتداء من C22 الي  AD

ولكم جزيل الشكرتجربة.xlsm

[محمد هشام.]

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

Sub test()
Dim wb As Workbook, WS As Worksheet, dest As Worksheet
Set wb = ThisWorkbook: Set WS = wb.Sheets("Sheet1"): Set dest = wb.Sheets("Sheet2")

Dim j&, col&, ligne&, r As String
Dim Rng As Range:   col = 12: r = dest.[B19]
ligne = WS.Cells(Rows.Count, col).End(xlUp).Row
  
 With Application
    .ScreenUpdating = False
dest.Range("C22", Range("AD" & Rows.Count).End(4)).ClearContents
    
For j = 22 To ligne
If UCase(WS.Cells(j, col)) = r Then
            
    Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30))
        dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value
      End If
    
    Next j
If Application.WorksheetFunction.CountA(dest.Range("C22:AD22")) = 0 Then
     MsgBox "غير موجود" & " / " & r, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه"
End If
   .ScreenUpdating = True
  End With
End Sub

 

 

تجربة 2.rar

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

[2saad]

شكرا جزيلا يا استاذ محمد

[محمد هشام.]

 ملاحظة : في حالة قمت بحدف عناوين الاعمدة سيتم نسخ البانات بعد اخر خلية فارغة في عمود C  ولتثبيت اللصق في الصف 22 ما عليك هو تعديل الصفوف التالية 

For j = 22 To ligne
If UCase(WS.Cells(j, col)) = r Then
    Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30))
       If dest.[C22] = Empty Then
        dest.[C22].Resize(1, 28).Value = Rng.Value
       Else: dest.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Resize(1, 28).Value = Rng.Value
       End If
      End If
''''''''''''''''''''''''''''''او''''''''''''''''''''''''''''
Dim dlr As Long
For j = 22 To ligne
If UCase(WS.Cells(j, col)) = r Then
  dlr = dest.Cells(Rows.Count, "C").End(xlUp).Row
     If dlr < 21 Then dlr = 21
    Set Rng = WS.Range(WS.Cells(j, 3), WS.Cells(j, 30))
        dest.Range("C" & dlr).Offset(1).Resize(1, 28).Value = Rng.Value
      End If
    
    Next j

 

[2saad]

الله يبارك فيك وفي أمثالك