عرض الاسماء والدرجات من شيت لاخر عند الاختيار بالقائمة المنسدلة

adel123 · يناير 15, 2020

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

الى السادة خبراء الاكسيل وكما تعودنا دائماً الحل لكل مشكلة تواجهنا بالعمل

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

ولكم جزيل الشكر

AA.xlsx

**سليم حاصبيا** · يناير 15, 2020

حرب هذا الماكرو

Option Explicit

Sub get_my_studiants()
Application.ScreenUpdating = False
Dim A As Worksheet
Dim B As Worksheet
Set A = Sheets("ALL_STD")
Set B = Sheets("B")
Dim col%, r, x, LB
LB = B.Cells(Rows.Count, "B").End(3).Row
If LB < 5 Then LB = 5
B.Range("a5").Resize(LB - 4, 6).Clear
Dim my_clas$: my_clas = B.Range("e2")
Dim my_mad$: my_mad = B.Range("K2").Value

 If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub
  col = A.Rows(1).Find(my_clas, lookat:=1).Column
  r = A.Columns(1).Find(my_mad, lookat:=1).Row
  x = Application.CountIf(A.Columns(1), my_mad)
   B.Range("b5").Resize(x).Value = _
   A.Cells(r, 2).Resize(x).Value
  B.Range("c5").Resize(x, 3).Value = _
  A.Cells(r, col).Resize(x, 3).Value
  With B.Range("A5").Resize(LB - 4, 6)
    .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)"
    .Columns(1).Interior.ColorIndex = 6
    .Borders.LineStyle = 1
    .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)"
    .Value = .Value
    .Font.Size = 26
    .Font.Bold = True
    .InsertIndent 1
  End With
Exit_Sub:
  Application.ScreenUpdating = True
End Sub

الملف مرفق

My_students.xlsm

adel123 · يناير 19, 2020

استاذنا الفاضل / سليم حاصبيا

الاستاذة الافاضل مبدعي منتدى الاكسيل

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

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

مرفق الملف بدون حماية وملف بحماية برقم سري 123 لحل المشكلة

تقبل تحياتي

My_students (1).xlsm My_students (6).xlsm

تم تعديل يناير 19, 2020 بواسطه adel123

**احمد بدره** · يناير 19, 2020

بعد إذن أستاذنا الفاضل سليم

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

جرب هذا

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.HasFormula = True Then
ActiveCell.Offset(0, 1).Select
End If
End Sub

My_students (1).xlsm

تم تعديل يناير 19, 2020 بواسطه احمد بدره

**سليم حاصبيا** · يناير 19, 2020

قبل اول كلمة Dim في الماكرو اكتب هذا السطر

و بذلك يقوم الماكرو بعمله حتى ولو كانت الورقة محمية

ActiveSheet.Protect "123", UserInterfaceOnly:=1

ليصبح الماكرو بهذا الشكل

Option Explicit

Sub get_my_studiants()
Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++++++++++++++++
ActiveSheet.Protect "123", UserInterfaceOnly:=1
'++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim A As Worksheet
Dim B As Worksheet
Set A = Sheets("ALL_STD")
Set B = Sheets("B")
Dim col%, r, x, LB
LB = B.Cells(Rows.Count, "B").End(3).Row
If LB < 5 Then LB = 5
B.Range("a5").Resize(LB - 4, 6).Clear
Dim my_clas$: my_clas = B.Range("e2")
Dim my_mad$: my_mad = B.Range("K2").Value

 If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub
  col = A.Rows(1).Find(my_clas, lookat:=1).Column
  r = A.Columns(1).Find(my_mad, lookat:=1).Row
  x = Application.CountIf(A.Columns(1), my_mad)
   B.Range("b5").Resize(x).Value = _
   A.Cells(r, 2).Resize(x).Value
  B.Range("c5").Resize(x, 3).Value = _
  A.Cells(r, col).Resize(x, 3).Value
  With B.Range("A5").Resize(LB - 4, 6)
    .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)"
    .Columns(1).Interior.ColorIndex = 6
    .Borders.LineStyle = 1
    .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)"
    .Value = .Value
    .Font.Size = 26
    .Font.Bold = True
  
  End With
Exit_Sub:
  Application.ScreenUpdating = True
End Sub

الملف مرفق

My_students_Protected.xlsm

**احمد بدره** · يناير 19, 2020

ممكن تبدليه بهذا الكود

Private Sub Worksheet_Selectionchange(ByVal Target As Range)

If Target.HasFormula = True Then

ActiveCell.Offset(0, 1).Select

ElseIf Target.MergeCells = True And Target.HasFormula = True Then Target.Offset(0, 1).Select

ElseIf ActiveCell.HasFormula = True And ActiveCell.MergeCells = True Then ActiveCell.Offset(0, 1).Select
End If

End Sub

و بعذ إذن أستاذنا الفاضل سليم أرى أن يكون التعديل هكذا

اكتب في السطر الذي قبل كلمة Dim في الماكرو

ActiveSheet.Unprotect "123"

واكتب في السطر الذي قبل كلمة End sub

ActiveSheet.Protect "123"

Option Explicit

Sub get_my_studiants()
Application.ScreenUpdating = False
ActiveSheet.Unprotect "123"
Dim A As Worksheet
Dim B As Worksheet
Set A = Sheets("ALL_STD")
Set B = Sheets("B")
Dim col%, r, x, LB
LB = B.Cells(Rows.Count, "B").End(3).Row
If LB < 5 Then LB = 5
B.Range("a5").Resize(LB - 4, 6).Clear
Dim my_clas$: my_clas = B.Range("e2")
Dim my_mad$: my_mad = B.Range("K2").Value

 If my_clas = "" Or my_mad = "" Then GoTo Exit_Sub
  col = A.Rows(1).Find(my_clas, lookat:=1).Column
  r = A.Columns(1).Find(my_mad, lookat:=1).Row
  x = Application.CountIf(A.Columns(1), my_mad)
   B.Range("b5").Resize(x).Value = _
   A.Cells(r, 2).Resize(x).Value
  B.Range("c5").Resize(x, 3).Value = _
  A.Cells(r, col).Resize(x, 3).Value
  With B.Range("A5").Resize(LB - 4, 6)
    .Columns(1).Formula = "=if(B5="""","""",max($A$4:a4)+1)"
    .Columns(1).Interior.ColorIndex = 6
    .Borders.LineStyle = 1
    .Columns(6).Formula = "=RANK(E5,$E$5:$E$29,0)+COUNTIF($E5:E$5,E5)"
    .Value = .Value
    .Font.Size = 26
    .Font.Bold = True
    .InsertIndent 1
  End With
Exit_Sub:
  Application.ScreenUpdating = True
  ActiveSheet.Protect "123"

End Sub

My_students (1).xlsm

adel123 · فبراير 11, 2020

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

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

ومرفق نفس الملف باضافة شيت لاستخراج الاوائل

ولكم جزيل الشكر

My_students (1) (2).xlsm

**سليم حاصبيا** · فبراير 11, 2020

جرب هذا الكود

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Application.EnableEvents = False
 If Target.Address = "$C$5" And Target.Count = 1 Then
 get_10_studiants
 End If
  Application.EnableEvents = True
End Sub
'=========================

Sub get_10_studiants()
Application.ScreenUpdating = False

  Dim A As Worksheet, F As Worksheet
  Dim find_rg As Range
  Dim my_clas$
  Dim Obj As Object
  Dim x%, LF%, Ro%, first%, last%, i%
  Dim arr(9)

Set A = Sheets("ALL_STD")
Set F = Sheets("first")
my_clas = F.Range("C5")
LF = F.Cells(Rows.Count, "b").End(3).Row
If LF < 8 Then LF = 8
F.Range("A8:C" & LF).ClearContents
Ro = A.Cells(Rows.Count, 1).End(3).Row
Set Obj = CreateObject("System.collections.arraylist")
Set find_rg = A.Range("a:a").Find(my_clas, lookat:=1)
        If Not find_rg Is Nothing Then
          first = find_rg.Row:  last = first
            Do
               Obj.Add A.Range("AF" & last).Value
               Set find_rg = A.Range("a:a").FindNext(find_rg)
                last = find_rg.Row
               If last = first Then Exit Do
            Loop
       End If
        Obj.Sort: Obj.Reverse
  For i = 0 To 9
   F.Range("A8").Offset(i) = i + 1
   arr(i) = Obj(i)
    Next
   F.Range("c8").Resize(i) = Application.Transpose(arr)
   F.Range("B8").Resize(i).Formula = _
   "=IFERROR(INDEX(ALL_STD!$B$8:$B$706,MATCH(C8,ALL_STD!$AF$8:$AF$706,0)),"""")"
   F.Range("a7").CurrentRegion.Value = _
   F.Range("a7").CurrentRegion.Value
End Sub

الملف مرفق

First_10.xlsm

adel123 · فبراير 13, 2020

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

عند نسخ الكود للاستفادة منه بملف اخر وعند تشغيل الكود تظهر رسالة خطأ كما هو بالصورة

هل هناك حل لذلك لكي يستفاد من الكود بملفات اخرى

**سليم حاصبيا** · فبراير 13, 2020

حمل الملف لوضع اليد على الخطأ وتصحيحه

adel123 · فبراير 13, 2020

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

استاذي المحترم والمبدع سليم حاصبيا

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

ومرفق العمل

هل يمكن لكود استخراج العشر الاوائل العمل لاكثر من صف بنفس الصفحة ؟

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

AAA.xlsm

**سليم حاصبيا** · فبراير 13, 2020

جرب هذا الكود

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

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
 Application.EnableEvents = False
 If Not Intersect(Target, Range("All_class")) Is Nothing _
  And Target.Count = 1 Then
    If Target = vbNullString Then
     Target.Offset(3, -2).Resize(10, 3).ClearContents
     GoTo Exit_me
    Else
      get_10_studiants (Sheets("first").Range(Target.Address))
    End If
 End If
Exit_me:
  Application.EnableEvents = True
End Sub
'=========================

Sub get_10_studiants(rg As Range)
  
  Dim A As Worksheet, F As Worksheet
  Dim find_rg As Range, cel As Range
  Dim my_clas$, t
  Dim Obj As Object
  Dim x%, LF%, Ro%, first%, last%, i%
  Dim arr(9), Copy_rg As Range
  Dim adrs$
Set A = Sheets("ALL_STD")
Set F = Sheets("first")
my_clas = rg
adrs = rg.Address

rg.Offset(3, -2).Resize(10, 3).ClearContents
Set Copy_rg = rg.Offset(3, -2).Resize(10, 3)

Ro = A.Cells(Rows.Count, 1).End(3).Row
Set Obj = CreateObject("System.collections.arraylist")
Set find_rg = A.Range("a:a").Find(my_clas, lookat:=1)
        If Not find_rg Is Nothing Then
          first = find_rg.Row:  last = first
            Do
               Obj.Add A.Range("AF" & last).Value
               Set find_rg = A.Range("a:a").FindNext(find_rg)
                last = find_rg.Row
               If last = first Then Exit Do
            Loop
       End If
        Obj.Sort: Obj.Reverse
  For i = 0 To 9
     Copy_rg.Cells(1, 1).Offset(i) = i + 1
     arr(i) = Obj(i)
  Next
    Copy_rg.Cells(1, 3).Resize(i) = Application.Transpose(arr)
For Each cel In Copy_rg.Columns(2).Cells
  t = "=INDEX(ALL_STD!$B$3:$B$710,MATCH(" & adrs & "&" & cel.Offset(, 1) & _
  ",ALL_STD!$A$3:$A$710&ALL_STD!$AF$3:$AF$710,0))"
  cel = Evaluate(t)
Next

End Sub

الملف مرفق

Many_Class_In One_Sheet.xlsm

adel123 · فبراير 25, 2020

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

اخواني الخبراء بمنتدى الاكسيل

مرفق ملف بعد اضافة شيت نريد استخراج الطلاب الحاصلين على معدل 90 فما فوق الموضح بالعمود (AE ) مع توضيح اسم الطالب والصف والمعدل

ولسيادتكم جزيل الشكر واسف على كثرة الاستفسار

Many_Class_In One_Sheet (1) (1).xlsm

تسجيل الدخول

عرض الاسماء والدرجات من شيت لاخر عند الاختيار بالقائمة المنسدلة

الردود الموصى بها

adel123

سليم حاصبيا

adel123

احمد بدره

سليم حاصبيا

احمد بدره

adel123

سليم حاصبيا

adel123

سليم حاصبيا

adel123

سليم حاصبيا

adel123

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information