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

hamed.34552 · أغسطس 18, 2019

السلام عليكم

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

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

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

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

ملحوظة

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

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

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

**أحمد يوسف** · أغسطس 18, 2019

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

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

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

**سليم حاصبيا** · أغسطس 18, 2019

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


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

aboesa · أغسطس 18, 2019

hamed.34552 · أغسطس 19, 2019

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

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

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

**ناصر سعيد** · أغسطس 19, 2019

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

=======

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

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

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

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

تم تعديل أغسطس 19, 2019 بواسطه ناصر سعيد
زياده في التوضيح

hamed.34552 · أغسطس 20, 2019

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

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

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

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

hamed.34552 · أغسطس 20, 2019

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

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

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

hamed.34552 · أغسطس 21, 2019

إلى الاستاذ ناصر هذا هو الملف يعمل

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

**ناصر سعيد** · أغسطس 21, 2019

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

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

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

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

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

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

**ناصر سعيد** · أغسطس 21, 2019


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

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

**سليم حاصبيا** · أغسطس 21, 2019

منذ ساعه, ناصر سعيد 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

**احمد بدره** · أغسطس 21, 2019

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

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

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

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

**ناصر سعيد** · أغسطس 21, 2019

حفظكم الله ورعاكم ... يارب

الاستاذ الكبير سليم

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

يبارك فيكما ربنا

===

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

**ناصر سعيد** · أغسطس 21, 2019

========

من فضلكم مامعنى هذا السطر ؟

Dim R As Integer, M%: M = 5

**سليم حاصبيا** · أغسطس 21, 2019

الشارة % هي اختصار لعبارة As Integer

واشارة # هي اختصار لعبارة As Double

واشارة $ هي اختصار لعبارة As String

وهناك الكثير

**ناصر سعيد** · أغسطس 22, 2019

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

hamed.34552 · أغسطس 23, 2019

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

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

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

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

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

مصطفى محمود مصطفى · أغسطس 26, 2019

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

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

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

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

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

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

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

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

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

اليك الملف

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

**ناصر سعيد** · أغسطس 26, 2019

جزاك الله كل خير استاذ مصطفى

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

**احمد بدره** · أغسطس 26, 2019

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

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

هناك فكرة

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

Shool.xlsm

تسجيل الدخول

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

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

hamed.34552

أحمد يوسف

سليم حاصبيا

aboesa

hamed.34552

ناصر سعيد

hamed.34552

hamed.34552

hamed.34552

ناصر سعيد

ناصر سعيد

سليم حاصبيا

احمد بدره

ناصر سعيد

ناصر سعيد

سليم حاصبيا

ناصر سعيد

hamed.34552

مصطفى محمود مصطفى

ناصر سعيد

احمد بدره

Join the conversation

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

تصفح الموقع

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

Support

Important Information