فلترة والفصل بين كل فئة

[رشراش]

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

اريد كود بحيث عندما اختار من قائمة منسدلة نوع الفلترة تتم الفلترة بحيث يكون فاصل بين كل فئة.

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

مسبقا شكرا وجزاكم الله خيرا

المرفق.

الفلترة فيتم الفصل بين كل فئة.rar

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub CallData()
Dim ws As Worksheet, Sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long, x As Long
Dim List As String, DataList As String
Set ws = Sheets("BD")
Set Sh = Sheets("نتيجة")
List = Sh.Range("D1").Value
DataList = Sh.Range("E1").Value
If DataList = "" Then Exit Sub
Sh.Range("A4:G" & Sh.Range("B" & Rows.Count).End(xlUp).Row + 3).ClearContents
x = WorksheetFunction.Match(List, ws.Range("A1:G1"), 0)
Arr = ws.Range("A2:G" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, x) = DataList Then
p = p + 1
For j = 1 To 7
Temp(p, j) = Arr(i, j)
Next
End If
Next
If p > 0 Then Sh.Range("A4").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub

 

[سليم حاصبيا]

ريما كان المطلوب

 

الفلترة فيتم الفصل بين كل فئة Salim.xls

[سليم حاصبيا]

تم النعديل على الملف من اجل اختيار بأي عامود تتم التصفية(تاريخ الميلاد / الوظيفة/ مكان الميلاد  الخ...)

فقط اختر العامود المناسب من الخلية E1 و اضغط الزر   Give_Me_ Data_Please

 

 

spec.filter_2010.xlsm

[رشراش]

أستاذي سليم

بداية الف شكر وجزاك الله خيرا

إنما يبقى لدينا اشكال صغير هو أن الرقم التسلسلي ليس معيارا فمثلا لو اضفنا اسماء اخرى القائمة دونما ترقيمها يحدث مشكل اثناء الفلترة

وبالتالي أريد أن اي خانة او خانات غير مملؤوة لا تعيق الفلترة

شكرا اساتذتي الكرام.

[رشراش]

أريد أن اي خلية او خلايا غير مملؤوة لا تعيق الفلترة...

هذا من جهة

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

الثانية فيها ثلاثون يبداء ترقيمها من واحد الى ثلاثون.... وهكذا

 

شكرا اساتذتي الكرام.

تم تعديل فبراير 14, 2018 بواسطه رشراش
خطاء املائي

[سليم حاصبيا]

بالنسية للسؤال الاول 

استبدل الماكرو بهذا

Option Explicit
Option Base 1
Sub filter_for_ME()
Dim y%, t%, i%, match%, r%: r = 3
Dim S_sh As Worksheet: Set S_sh = Sheets("BD")
Dim T_sh As Worksheet: Set T_sh = Sheets("نتيجة")
Dim My_Table As Range: Set My_Table = S_sh.Range("a1").CurrentRegion
Dim arr(), n_Rows%: n_Rows = My_Table.Rows.Count
Dim k%, a%, Arr_Num%: Arr_Num = 1
Dim ar_ad()
Dim tt$
Dim Saerch_Rg As Range
Dim my_col%
T_sh.Range("a3:g1000").Clear
ar_ad = Array("=$A2", "=$B2", "=$C2", "=$D2", "=$E2", "=$F2", "=$G2")
match = Application.match(T_sh.[d1], S_sh.Rows(1), 0)
Application.ScreenUpdating = False
S_sh.Activate
'====================================
  For k = 2 To n_Rows
  If Cells(k, match) = vbNullString Then Cells(k, match) = "(EMPTY)"
  Next
 For k = 2 To n_Rows
    y = Application.CountIf(S_sh.Range(Cells(1, match), Cells(k, match)), S_sh.Cells(k, match))
    If y = 1 Then ReDim Preserve arr(1 To Arr_Num): _
    arr(Arr_Num) = S_sh.Cells(k, match): Arr_Num = Arr_Num + 1
 Next
 T_sh.Activate
'=========================================
 For k = 1 To UBound(arr)
    T_sh.Range("E1") = arr(k)
    tt = Application.Index(ar_ad, match) & "=" & T_sh.Name & "!$E$1"
    T_sh.Range("m2") = tt
    My_Table.AdvancedFilter Action:=2, criteriarange:=T_sh.Range("m1:m2"), _
      copytorange:=T_sh.Range("a" & r)
    t = T_sh.Cells(Rows.Count, 1).End(3).Row
    r = t + 2
  Next
        For k = 2 To n_Rows
        If S_sh.Cells(k, match) = "(EMPTY)" Then S_sh.Cells(k, match) = vbNullString
        Next
    With Range("a3:G" & r - 2).SpecialCells(2, 23)
        .Borders.LineStyle = 1
        .InsertIndent 1
       
    End With
  Set Saerch_Rg = T_sh.Range("a3:G" & r - 2).Find("(EMPTY)")
     If Not Saerch_Rg Is Nothing Then
            my_col = Saerch_Rg.Column
            For a = 4 To r - 2
                If T_sh.Cells(a, my_col) = "(EMPTY)" Then
                 T_sh.Cells(a, my_col) = vbNullString
                End If
            Next
     End If
T_sh.Range("e1").Clear: T_sh.Range("m1:m2").Clear
Erase arr: Erase ar_ad: Set Saerch_Rg = Nothing
Application.ScreenUpdating = True
End Sub

اما السؤال الثاني  لم افهم المطلوب

الملف من جديد

 

new_spec_filter.xlsm

[رشراش]

أستاذ وأخي بارك الله فيك واصلح شأنك وبارك في عمرك واهلك.

اليك الملف وبه الشرح لما حصلت عليه وما اريد الوصول اليه.....

وسامحني في ما منحتني من جهد ووقت...

new_spec_salim.rarFetching info...

 

تم تعديل فبراير 14, 2018 بواسطه رشراش
إضافة ملف

[سليم حاصبيا]

تم التعديل على الكود ليعمل كما تشاء

new_spec_Salim_With _Numaretion.xlsm

[رشراش]

استاذي... لما في شيت BD  في العمود A  لا يتم الترقيم سعوا مثلا فإن الكود يظهر رسالة خطاء وأريد تجاوز هذه الرسالة

مثلا لو محوت الترقيم من  10 الى آخر سطر  في BD وطبقت ستظهر لك الرسالة

دع اكسل يقوم بالترقيم أوتوماتيكياً بوضع هذه المعادلة في الخلية A2 في الصفحة BD , و سحبها نزولاً الى اي عدد من الصفوف تريد

=IF(B2="","",MAX($A$1:A1)+1)

 

[رشراش]

الفكرة ممتازة

لكن استاذي لديا اقتراح غير اني لا اعرف كيف اجسده

نضع المعادلة

=IF(B2="","",MAX($A$1:A1)+1)

التي طرحتها ضمن الاكواد

حيث لما نضغط زر الفلترة يقوم بتنفيذ المعادلة كخطوة اولى ثم ينفذ باقي الكود.....

فهل هذا ممكن

وفقك الله

الفكرة ممتازة

///// ممكن ذلك ياضافة هذين السطرين في الكود مباشرة بعد عبارة S_sh.Activate

S_sh.Range("a2:a" & n_Rows).Formula = "=IF(B2="""","""",MAX($A$1:A1)+1)"
S_sh.Range("a2:a" & n_Rows).Value = S_sh.Range("a2:a" & n_Rows).Value