اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

adel123

بواسطه adel123
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

adel123

adel123

قام بنشر
قام بنشر

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

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

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

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

AA.xlsx

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 7
  • Thanks 1
رابط هذا التعليق
شارك
adel123

adel123

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

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

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

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

تقبل تحياتي

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

تم تعديل بواسطه adel123
رابط هذا التعليق
شارك
احمد بدره

احمد بدره

قام بنشر
قام بنشر (معدل)

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

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

جرب هذا

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

تم تعديل بواسطه احمد بدره
  • Like 4
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

قبل اول كلمة 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

  • Like 2
رابط هذا التعليق
شارك
احمد بدره

احمد بدره

قام بنشر
قام بنشر

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

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

  • Like 2
رابط هذا التعليق
شارك
  • 4 weeks later...
adel123

adel123

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

My_students (1) (2).xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الكود 

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

  • Like 3
رابط هذا التعليق
شارك
adel123

adel123

قام بنشر
  • الكاتب
قام بنشر

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

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

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

2020-02-13_7-19-58.png

رابط هذا التعليق
شارك
adel123

adel123

قام بنشر
  • الكاتب
قام بنشر

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

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

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

ومرفق العمل 

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

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

AAA.xlsm

رابط هذا التعليق
شارك
  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

جرب هذا الكود

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

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
  • 2 weeks later...
adel123

adel123

قام بنشر
  • الكاتب
قام بنشر

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

 

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

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

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

Many_Class_In One_Sheet (1) (1).xlsm

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept