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

كود اختيار الناجحين ودور ثانى والراسبين


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

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

السلام عليكم 

الى الاساتذة الافاضل ارجو من سيادتكم ظبط الكود بملف الاكسل ...

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

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

عند اختيار  راسب من الكومبوبوكس يختار الراسبين فى ورقة رسوب

ملحوظة 

انا عملت الكود يختار الناجحين لكن عند اختيار دور ثانى او راسب لا يعمل

وشكرا لسيادتكم

مدرسة بنبان الثانوية المشتركة منتظم نتيجة الصف الأول الثانوى 2019 (2).xlsm

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

وعليكم السلام

ليه احنا بنحب نصعب ونعسر على نفسنا

لماذا قمت بتصميم الملف بهذا الشكر ولم تقوم بعمل ملف اكسيل عادى فالملف صعب التعامل معه وبطىء للغاية من فضلك عليك بتعديل تصميم الملف بدون Split ؟!!!!!!

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

  • أفضل إجابة

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


Private Sub ComboBox1_Change()
Application.EnableEvents = False
On Error Resume Next
'''''''''''''''''''''''''''''
Dim sheet_to As Worksheet
Dim t$: t = ComboBox1.Value
Dim My_name$
Dim My_rg As Range
Select Case t
 Case "راسب": My_name = "رسوب"
 Case "ناجح": My_name = "ناجح"
 Case "دور ثانى": My_name = "دور ثان فى"
End Select
   
 Set My_rg = Sheets("الشيت").Range("a4").CurrentRegion
 On Error Resume Next

 Sheets(My_name).Cells.Clear
  My_rg.AutoFilter 20, t
  My_rg.SpecialCells(12).Copy Sheets(My_name).Range("a4")
  If Sheets("الشيت").FilterMode Then
  Sheets("الشيت").ShowAllData: My_rg.AutoFilter
  End If
  Application.EnableEvents = True
  End Sub

الملف مرفق

 

Shool.xlsm

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

شكر خاض جدا للاستاذ احمد يوسف............ والاستاذ سليم حاصبيا على الرد 

لكن بعد التعديل ومحاولات كثيرة على الملف تم ظبط الكود 

لكم منى كل التحية حامد مصطفى من مصر محافظة اسوان 

 

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

الاستاذ سليم يحفظك الرحمن

=======

ماهو التعديل الذي اضفته استاذ حامد ؟

ضع الملف النهائي بعد التعديل استاذ حامد

ليستفيد منه غيرك

جزاكم الله حيرا

تم تعديل بواسطه ناصر سعيد
زياده في التوضيح
رابط هذا التعليق
شارك

الاستاذ / ناصر سعيد

ارسل اليك الملف كما طلبت حضرتك للاستفادة

وشكرا لسيادتكم

 

مدرسة بنبان الثانوية المشتركة منتظم نتيجة الصف الأول الثانوى 2019 (2).xlsm

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

كما اشكر الاستاذ / سليم حاصبيا على الماكرو ....تم تجربته وهو جميل وفعال 

وارجو رد الاستاذ / ناصر سعيد بعد تجربة الملف الذى ارسلته له

ولكم التحية والاحترام .....اخيكم حامد 

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

كانت لي مشاركه هنا بخصوص

تعريف للاخ حامد بان ملفه لايعمل وبناء عليه تم ارسال ملف اخر من الاخ حامد

ولاادري من الذي حذف المشاركه

حسبنا الله ونعم الوكيل

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

جزاك الله خيرا

 

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


Private Sub ComboBox1_Change()

Dim R As Integer, M As Integer, N As Integer, o As Integer
'''''''''''''''''''''''''''''

M = 5: N = 5: o = 5
    Application.ScreenUpdating = False
For R = 5 To 100

       If (Me.ComboBox1.Value = "ناجح" And Cells(R, 20) = "ناجح") Then
         
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
             
            M = M + 1
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
                    ''' رقم عمود المعيار وكلمة المعيار
            ElseIf (Me.ComboBox1.Value = "دور ثانى" And Cells(R, 20) = "دور ثانى") Then
            
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("دور ثان فى").Range("A" & N).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            
                    '''  اجعل الرقم 1  الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل
            N = N + 1
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
      
            Else
            If Me.ComboBox1.Value = "راسب" And Cells(R, 20) = "راسب" Then
            
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("رسوب").Range("A" & o).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
         o = o + 1
         
    End If
   End If
Next
End Sub

Private Sub textbox1_change()

If TextBox1 = "" Then Exit Sub
sheet3.Activate
ss = sheet3.Cells(Rows.Count, 4).End(xlUp).Row
k = 0
For Each c In Range("d5:d" & ss)
If c Like TextBox1.Value & "*" Then
ListBox1.AddItem
ListBox1.List(k, 0) = Cells(c.Row, 4).Value
ListBox1.List(k, 1) = c.Row
k = k + 1
End If
Next c
End Sub

هذا هو الكود الذي وضعته في ملفك الاخير في حدث الصفحه

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

منذ ساعه, ناصر سعيد said:


Private Sub ComboBox1_Change()

Dim R As Integer, M As Integer, N As Integer, o As Integer
'''''''''''''''''''''''''''''

M = 5: N = 5: o = 5
    Application.ScreenUpdating = False
For R = 5 To 100

       If (Me.ComboBox1.Value = "ناجح" And Cells(R, 20) = "ناجح") Then
         
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("ناجح").Range("A" & M).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
             
            M = M + 1
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    
                    ''' رقم عمود المعيار وكلمة المعيار
            ElseIf (Me.ComboBox1.Value = "دور ثانى" And Cells(R, 20) = "دور ثانى") Then
            
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("دور ثان فى").Range("A" & N).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            
                    '''  اجعل الرقم 1  الى الرقم 2وانظر في صفحة الدور الثاني بعد الترحيل
            N = N + 1
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
      
            Else
            If Me.ComboBox1.Value = "راسب" And Cells(R, 20) = "راسب" Then
            
            Range("A" & R).Resize(1, 20).Copy
            
                      '''  سيتم اللصق في هذا الشيت
            Sheets("رسوب").Range("A" & o).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
         o = o + 1
         
    End If
   End If
Next
End Sub

Private Sub textbox1_change()

If TextBox1 = "" Then Exit Sub
sheet3.Activate
ss = sheet3.Cells(Rows.Count, 4).End(xlUp).Row
k = 0
For Each c In Range("d5:d" & ss)
If c Like TextBox1.Value & "*" Then
ListBox1.AddItem
ListBox1.List(k, 0) = Cells(c.Row, 4).Value
ListBox1.List(k, 1) = c.Row
k = k + 1
End If
Next c
End Sub

هذا هو الكود الذي وضعته في ملفك الاخير في حدث الصفحه

لا أعلم لما هذا التفصيل والاطالة في الكود واستعمال ثلاث متغيرات(R,M,O) (الجزء الاول من الكود)

يمكن الاختصار  هكذا (اذا كنت لا تريد ان يعمل علي اوتو _فلتر)

Option Explicit
Private Sub ComboBox1_Change()
Dim R As Integer, M%: M = 5
Dim My_sh As Worksheet
   Application.ScreenUpdating = False
    Select Case Me.ComboBox1.Value
        Case "راسب": Set My_sh = Sheets("رسوب")
        Case "ناجح": Set My_sh = Sheets("ناجح")
        Case "دور ثانى": Set My_sh = Sheets("دور ثان فى")
        Case Else: GoTo End_Me
   End Select
For R = 5 To 100
   If Sheets("الشيت").Cells(R, 20) = Me.ComboBox1.Value Then
      Sheets("الشيت").Range("A" & R).Resize(1, 20).Copy
       My_sh.Range("A" & M).PasteSpecial xlPasteValues
     
             
            M = M + 1
       End If
       Next
End_Me:
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
     End Sub

 

 

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

رائع بارك الله فيك أستاذنا الفاضل أستاذ سليم

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

فيصبح الكود  هكذا

Private Sub ComboBox1_Change()
Dim R As Integer, M%: M = 5
Dim My_sh As Worksheet
   Application.ScreenUpdating = False
    Select Case Me.ComboBox1.Value
        Case "راسب": Set My_sh = Sheets("رسوب")
        Case "ناجح": Set My_sh = Sheets("ناجح")
        Case "دور ثانى": Set My_sh = Sheets("دور ثان فى")
        Case Else: GoTo End_Me
   End Select
 My_sh.Range("A5:t1005").ClearContents
For R = 5 To 100
   If Sheets("الشيت").Cells(R, 20) = Me.ComboBox1.Value Then
      Sheets("الشيت").Range("A" & R).Resize(1, 20).Copy
       My_sh.Range("A" & M).PasteSpecial xlPasteValues
     
             
            M = M + 1
       End If
       Next
End_Me:
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
     End Sub

 

 

Shool.xlsm

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

شكرا لجميع المهتمين بالفيجوال بيزيك وكل من شارك معى الفكرة 

لكن اريد التوضيح لشيء بسيط انا ارسلت ملف تجربة لكم وفيه كود الناجحين والراسبين وهكذا وهنا اكواد اخرى اجربها كود textbox و listbox

كنت اريد عندما اكتب فى التكيست بوكس يجلب الاسماء فى الليست بوكس

لذلك يكون الملف به اشياء كثيرة واكواد كثيرة

ولكم منى كل الحب والتقدير لأساتذتى الكرام

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

في ٢٣‏/٨‏/٢٠١٩ at 02:56, ناصر سعيد said:

نتعشم في اضافه ميزه التسطير التلقائي مع الخط الغامق وتوسيط الارقام والكلمات

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

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

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

استاذ سليم والاستاذ احمد

اخي ناصر سعيد نسق الشيتات بما تريد وسيظهر الترحيل كما منسق مسبقا للشيت 

اما الترقيم التلقائي فاستخدم اي معادلة للترقيم التلقائي مثلا SUBTOTAL  او غيرها

واجعل النسخ والترحيل يبدا من العمود الثاني اي غير المدى من "A" الى "B" الموجود في الكود

اليك الملف

Shoolترقيم تلقائي.xlsm

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

قم بعمل التنسيق في كل ورقة من الأوراق

تم عمل ماكرو إظهار كل الصفوف حتى تتمكن من تنسيق الخلايا

هناك فكرة

يمكن عمل حيلة وهي إخفاء الصفوف الفارغة تلقائيًا عند فتح ورقة العمل

Shool.xlsm

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

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