تعديل كود الفلترة في المرفق

[ArefALhakimi]

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

[محمد هشام.]

11 دقائق مضت, ArefALhakimi said:

فلترة اسم الطالب التي لا تتطابق درجاته في الصف الاول والصف الثاني تطابق تام

مادا تقصد بالفصل الاول والثاني الورقة عليها الفصل الاول فقط 

 

[ArefALhakimi]

اخي الفاضل ما اقصده هو  أن الورقة المسمى الكشف المطلوب البحث فيها عن اسم الطالب ودرجاته   في حال تكرر اسم الطالب و تكون درجاته متطابقة يهمل من الاستدعاء لورقة الفرز  وفي حالة اي اختلاف في اسم الطالب او درجه من درجات المواد يتم استدعاء هذا الطالب في ورقة فرز الدرجات التي عليها التنسيق الشرطي  ــــ  وقد تم ترتيب الاسماء في الكشف بعيدا عن مسمى الفصل الاول او الفصل الثاني شاكرا جهودكم ..

 

مطابقة درجات.xlsm

[محمد هشام.]

 

( استدعاء هذا الطالب في ورقة فرز الدرجات التي عليها التنسيق الشرطي !!!!)

هناك تناقض نوعا ما 

1) داخل الملف ذكرت انك تريد جلب جميع الطلاب المختلفة درجاتهم دفعة واحدة مع تجاهل من هم درجاتهم متطابقة

2) في حالة كان الطالب غير مكرر اسمه هل يتم جلب بياناته او يتم تجاهلها

يجب الإجابة على هذه الاستفسارات لنستطيع مساعدتك.

 

تم تعديل يونيو 18, 2023 بواسطه Mohamed Hicham

[محمد هشام.]

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

 

Sub comparecells_MH()
Dim i&, j&, k&, m&, RwsDest&, derlig&
Dim a As Variant, b As Variant

 Dim WSData As Worksheet: Set WSData = Sheets("الكشف")
 Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات")
 derlig = WSDest.Range("C" & Rows.Count).End(xlUp).Row + 1

Application.ScreenUpdating = False

 a = WSData.Range("C6:T" & WSData.Range("D" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  
  For i = 1 To UBound(a, 1) - 1 Step 2
    For j = 3 To UBound(a, 2)
      If a(i, j) <> a(i + 1, j) Then
        k = k + 1
        For m = 1 To UBound(a, 2)
          b(k, m) = a(i, m)
          b(k + 1, m) = a(i + 1, m)
        Next
        k = k + 1
        Exit For
      End If
      
    Next
  Next

WSDest.Range("C6").Resize(UBound(b, 1), UBound(b, 2)).Value = b
  With WSDest.Range("C6:T" & WSDest.Cells.SpecialCells(xlCellTypeLastCell).Row)
    
    If .Row < 6 Then Exit Sub
   For Each r In .EntireRow
If Application.CountA(Intersect(r, WSDest.Range("C:D"))) Then _
If Application.CountA(Intersect(r, WSDest.Range("E:T"))) = 0 Then Intersect(r, WSDest.Range("C:D")).EntireRow.Delete
    
    Next

RwsDest = WSDest.Range("D" & Rows.Count).End(xlUp).Row
    With WSDest.Cells(6, Columns.Count).End(xlToLeft).Offset(0, 1).Resize(RwsDest)
      .Formula = "=if(countifs(D:D,D6)>1,"""",1)"
      .Value = .Value
           Intersect(.SpecialCells(xlConstants).EntireRow, WSDest.Range("A:U")).Delete
           WSDest.Range("U6:U" & derlig).ClearContents
     
  End With
End With

  Application.ScreenUpdating = True

End Sub

 

مطابقة درجات V1.xlsm

[ArefALhakimi]

اخي الفاضل محمد بذلت مجهود تشكر عليه ولكني لاحظت أن الكود يستدعي كل الاسماء وانا اريد فقط  كمثال :الطلاب في المرفق الذين اسماؤهم باللون الاصفر في ورقة (الكشف )  ودرجاتهم لكل المواد او بعضها خلاباها باللون الاحمر هذاالصنف المراد استدعائه في ورقة فرز الدرجات فقط  وتجاهل الطلاب الذين صفي درجاتهم باللون الاخضر  و حتى تقترب الفكرة فكل طالب له صفين من الدرجات التطابق المقصود تطابق الدرجة في الصف الاعلى مع الدرجة الاسفل منها لنفس الطالب في ورقة الكشف  واعتذر للاطالة لشعوري بعدم وصول الفكرة المطلوب على اساسها الكود  شاكرا ومقدرا جهودكم جميعا ايها الرائعون

 

مطابقة2.rar مطابقة2.rar

تم تعديل يونيو 20, 2023 بواسطه ArefALhakimi
الايضاح اكثر

[محمد هشام.]

Sub comparecells_V2()
  Dim i As Long, j As Long, k As Long
Dim WSData As Worksheet: Set WSData = Sheets("الكشف")
Dim WSDest As Worksheet: Set WSDest = Sheets("فرزدرجات")
  
  Application.ScreenUpdating = False
  k = 6
  With WSData
    For i = 6 To .Range("D" & Rows.Count).End(3).Row Step 2
      For j = 5 To .Cells(i, Columns.Count).End(1).Column
        If .Cells(i, j).Value <> .Cells(i + 1, j) Then
          .Rows(i & ":" & i + 1).Copy WSDest.Range("A" & k)
          k = k + 2
          Exit For
        End If
      Next
    Next
  End With
  Application.ScreenUpdating = True
End Sub

اليك كود اخر يؤدي نفس المهمة فقط للتاكد من صحة الاكواد 

 اخي لكي يشتغل معك الكود بشكل سليم يجب اولا تنظيم ملفك على الشكل التالي 

1) لقد دكرت بان اسماء الطلاب مكررة مرتين في  ملف الكشف كما جاء في ملفك المرفق. وقد اعتمدنا على هدا داخل الاكواد

 For i = 1 To UBound(a, 1) - 1 Step 2

يعني لابد من وجود الاسماء في وضعية متتابعة واحد تلو الاخر مع تطابق شكل كتابة الاسماء  وهدا مثال على ملف اخر قمت بنسخ بياناتك عليه والتاكد من تطابق الاسماء  يمكنك تجربته ووافينا بالنتيجة 

وهده صورة من ملفك بعد تنظيمه وحدف الاسماء الغير مكررة للتجربة 

 

 

 

TEST V2.xlsm

 

وهدا ملفك يمكنك تجربته كدالك 

 

مطابقة درجات V2.xlsm

تم تعديل يونيو 20, 2023 بواسطه Mohamed Hicham

[محمد هشام.]

وهدا اخر ملف قمت برفعه  دون ان اغير اي شيء في الاكواد فقط حاول جعل  الاسماء  الغير معدلة درجاتهم  في اخر قائمة الاسماء  لكي يتطبق شرط وجود الاسماء المعدلة بشكل متتابع وسوف يشتغل معك الكود بشكل صحيح 

 

 

‏‏مطابقة درجات V2.xlsm

تم تعديل يونيو 20, 2023 بواسطه Mohamed Hicham

[ArefALhakimi]

احسنت وأجدت وابدعت اخي محمد و سلمت يداك ووفقك الله مع خالص شكري وتقديري لك ولكل الاعضاء 

[محمد هشام.]

العفو اخي نحن سعداء باننا استطعنا مساعدتك  شكرا لتعليقاتكم الرقيقة

 

[ArefALhakimi]

سلام عليكم اخي محمد والسلام على الجميع 

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

مطابقة درجات.xlsm

[محمد هشام.]

قم باظافة هدا السطر في اول الكود مع تبديل كلمة Password بالباسوورد الخاص بك

WSDest.Unprotect "Password" 

وفي نهايته 

WSDest.Protect "Password"

 

تم تعديل يونيو 21, 2023 بواسطه Mohamed Hicham