عمل تصفية لعدة صفوف في شبت واحد

[صقر الخليج]

السلام عليكم وبها نبدأ اي موضوع

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

نص السؤال جاهز مع الصورة.rar

[محمد هشام.]

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

تفضل اخي ...قد تم اضافة جميع الاكواد الى الملف المرفق

Sub AutoF_Data() 
Dim c As Integer
Dim MH As String
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Y As ListObject, Y1 As ListObject, Y2 As ListObject
Dim Lastrow As Long
Lastrow = Feuil1.Range("H" & Rows.Count).End(xlUp).Row + 1

'خلية شرط معيار الفلترة
MH = Sheets("Sheet1").Range("C1").Value
If Len(Range("C1").Value) = 0 Then
  MsgBox "المرجوا ادخال معيار الفلترة"
 Exit Sub
End If
'افراغ النطاق قبل الترحيل
Range("H1:K" & Lastrow).Clear

'جدول البيانات
Set ws1 = Sheets("Sheet1")

'مكان وضع البيانات المفلترة
Set ws2 = Sheets("sheet1")

'في حالة الرغبة في اضافة شيت جديد وترحيل البيانات اليه
'Set ws2 = Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
'نسخ الى شيت موجود سابقا
'Set ws2 = Sheets("اسم الشيت")

''''''''''''''الجدول 1
Set Y = ws1.ListObjects(1)
Application.ScreenUpdating = False

'تحديد عمود معيار الفلترة
Y.Range.AutoFilter Field:=2, Criteria1:=MH
Y.Range.SpecialCells(xlCellTypeVisible).Copy

'تحديد موضع اللصق
ws2.Cells(3, 8).PasteSpecial xlValues
Application.CutCopyMode = False

'''''''''''''''الجدول 2
Set Y = ws1.ListObjects(3)
Y.Range.AutoFilter Field:=2, Criteria1:=MH
Y.Range.SpecialCells(xlCellTypeVisible).Copy
ws2.Cells(12, 8).PasteSpecial xlValues
Application.CutCopyMode = False
'''''''''''''''الجدول 3'''''''''''''''''''''''
Set Y = ws1.ListObjects(2)
Y.Range.AutoFilter Field:=2, Criteria1:=MH
Y.Range.SpecialCells(xlCellTypeVisible).Copy
ws2.Cells(21, 8).PasteSpecial xlValues
Application.CutCopyMode = False

'''''''''''''''نسخ رؤؤس الجداول'''''''''''''''''
Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(3, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes)
Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(12, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes)
Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(21, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes)

Feuil1.Activate
 ActiveSheet.ListObjects("Tableau3").Range.AutoFilter Field:=2
 ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=2
 ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2
 'تنسيقات الجداول
     Call MH3
    Application.ScreenUpdating = True

End Sub

بالتوفيق

 

 

تصفية في شيت واحد.xlsm