التصفية التلقائية لتشمل صفين

[يوسف عطا]

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

 

 

دور2.xls

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

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

اذا كنت تريد يمكن استحراج النتائج بواسطة الماكرو او المعادلات

[يوسف عطا]

اشكرك جزيل الشكر أستاذ سليم على إهتمامك
بالفعل تم إستخدام المعادلات لمعرفة نتيجة الطالب بعد وضع الدرجات فى الملف الأصلى وسوف أرفقه لمعاليكم غداً
ولكن الهدف من إستخدام التصفية التلقائية أن تكون صفحة طبع النتيجة هى نفسها صفحة غستخراج النتيجة بدون إستخدام كود الترحيل ل 3 صفحات أخرى
حيث النتائج ستكون ثلاثة
1. طالبات ناجحات ومنقولات
2. طالبات راسبات ولهن حق الإعادة بالمدرسة
3. طالبات راسبات وليس لهن حق الإعادة بالمدرسة
على كل حال سيكون الأمر أكثر وضوحاً عندما أرسل لمعاليكم الملف
 

تحياتى لمعاليكم سليم بك

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

تم معالجة الأمر بالنسبة للملف القديم الذي رفعته

الكود

Option Explicit
Sub filter_ME()
If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1")
Dim T_sh As Worksheet: Set T_sh = Sheets("Salim")
Dim lr%, i%, new_lr%, k%, x
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A6").CurrentRegion

ReDim arr(1 To 4)
arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11
With T_sh
    .Range("A4").Resize(1000, 11).ClearContents
    .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)"
     My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _
    .Range("A4"), 0
    .Range("Q2").ClearContents
End With
 '======================
 lr = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row
If lr < 5 Then lr = 5
For i = lr To 6 Step -1
 Rows(i).Insert
Next
new_lr% = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row
 If new_lr% < 6 Then new_lr% = 6
   For i = 6 To new_lr% + 1 Step 2

   x = Application.Match(T_sh.Cells(i - 1, 1), _
         S_sh.Columns(1), 0) + 1
        T_sh.Cells(i, 4).Resize(, 7).Value = _
        S_sh.Cells(x, 4).Resize(, 7).Value
   Next
   For i = 5 To new_lr% Step 2
    For k = 1 To 4
     T_sh.Cells(i, arr(k)).Resize(2, 1).MergeCells = True
     Next
     Next
 '==========================
Exit_Me:
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

الملف مرفق (انظر الى الصفحة salim   )

 

دورsalim.xls

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

تم معالجة الأمر بالنسبة للملف القديم الذي رفعته (نمو ذج اخر على 3 صفحات مستقلة مع تحديد نطاق الطباعة اللازم لكل صفحة)

الكود

Option Explicit
Sub filter_ME3()
If ActiveSheet.Name <> "ورقة1" Then GoTo Exit_Me
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1")
Dim T_sh As Worksheet
Dim lr%, i%, new_lr%, k%, x
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A6").CurrentRegion
 
    Select Case S_sh.Range("b1")
        Case "ناجح"
          Set T_sh = Sheets("Salim")
        Case "راسب وله حق الإعادة"
          Set T_sh = Sheets("Salim1")
        Case "راسب وليس له حق الإعادة"
          Set T_sh = Sheets("Salim2")
        Case Else
          GoTo Exit_Me
      End Select
      
ReDim arr(1 To 4)
arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11

With T_sh
    .Select
    .Cells(4, 1).Resize(1000, 11).ClearContents
    .Cells(1, 1) = S_sh.Range("b1")
    .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)"
     My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _
    .Range("A4"), 0
    .Range("Q2").ClearContents
    .Cells(1, 1) = vbNullString
               '======================
 lr = .Cells(Rows.Count, 1).End(3).Row
       If lr < 5 Then lr = 5
    For i = lr To 6 Step -1
      Rows(i).Insert
    Next
     new_lr% = .Cells(Rows.Count, 1).End(3).Row
       If new_lr% < 6 Then new_lr% = 6
   For i = 6 To new_lr% + 1 Step 2
     x = Application.Match(.Cells(i - 1, 1), _
         S_sh.Columns(1), 0) + 1
        .Cells(i, 4).Resize(, 7).Value = _
        S_sh.Cells(x, 4).Resize(, 7).Value
   Next
   For i = 5 To new_lr% Step 2
     For k = 1 To 4
        .Cells(i, arr(k)).Resize(2, 1).MergeCells = True
     Next
   Next
  End With
                '==========================
Exit_Me:
Erase arr
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

الملف مرفق

 

دورsalim 3 sheets.xls

[يوسف عطا]

 

تحياتى لمعاليكم سليم بك

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

دمت بود