طلب مساعدة فى عمل قوائم فصول

[حسين النجدى]

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

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

Microsoft Excel Worksheet جديد (3).xlsx

تم تعديل أكتوبر 7 بواسطه حسين النجدى

[أ / محمد صالح]

يمكنك تجربة هذه الكود في حدث التغيير في شيت قوائم الفصول

مع تصويب اسم الشيت قاعدة البيانات

كلك يمين على اسم الشيت قوائم الفصول ثم view code ثم لصق هذا الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$D$5" Then
        Dim wsDatabase As Worksheet
        Dim wsLists As Worksheet
        Dim lastRow As Long
        Dim i As Long
        Dim maleRow As Long, femaleRow As Long
        Dim lastMaleNumber As Long
        
        Set wsDatabase = ThisWorkbook.Sheets("قاعدة البيانات")
        Set wsLists = ThisWorkbook.Sheets("قوائم الفصول")
        
        wsLists.Range("A7:C40").ClearContents
        wsLists.Range("D7:F40").ClearContents
        
        maleRow = 7
        femaleRow = 7
        
        lastRow = wsDatabase.Cells(wsDatabase.Rows.Count, "B").End(xlUp).Row
        
        For i = 2 To lastRow
            If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then
                If wsDatabase.Cells(i, "D").Value = "ذكر" Then
                    wsLists.Cells(maleRow, 1).Value = maleRow - 6
                    wsLists.Cells(maleRow, 2).Value = wsDatabase.Cells(i, "B").Value
                    wsLists.Cells(maleRow, 3).Value = wsDatabase.Cells(i, "M").Value
                    maleRow = maleRow + 1
                End If
            End If
        Next i
        
        lastMaleNumber = maleRow - 7
        femaleRow = 7
        
        For i = 2 To lastRow
            If wsDatabase.Cells(i, "C").Value = wsLists.Range("D5").Value Then
                If wsDatabase.Cells(i, "D").Value = "انثى" Then
                    wsLists.Cells(femaleRow, 4).Value = lastMaleNumber + (femaleRow - 6)
                    wsLists.Cells(femaleRow, 5).Value = wsDatabase.Cells(i, "B").Value
                    wsLists.Cells(femaleRow, 6).Value = wsDatabase.Cells(i, "M").Value
                    femaleRow = femaleRow + 1
                End If
            End If
        Next i
    End If
End Sub

بالتوفيق

[حسين النجدى]

لم يفلح هذا معى اخى

لم يفلح للاسف

قوائم.xlsm

[أ / محمد صالح]

لم أقل في موديول جديد وإنما قلت في حدث التغيير يعني عند تغيير محتوى الخلايا في الشيت

وتمت إضافة الطريقة في المنشور الأصلي

[حسين النجدى]

اسف على الاطاله تغير اسم الشيت من اسم الصفحه تحت

[محمد هشام.]

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

كما وضح الأستاد @أ / محمد صالح  يجب عليك وضع الكود في حدث ورقة قوائم الفصول  

 لاكن  اخي @حسين النجدى الصورة تظهر مشكلة في أسماء أوراق العمل داخل مشروع VBA  حيث يتم عرض الأسماء على شكل "?????"  هذه المشكلة غالبا تتعلق بعدم دعم الترميز العربي بشكل صحيح داخل Excel أو محرر VBA مما يسبب ظهور رسالة الخطأ معك .  تأكد من أن إعدادات اللغة في نظام التشغيل  عندك على الجهاز مضبوطة للغة العربية اذهب إلى Control Panel > Clock and Region > Region ثم في تبويب Administrative اضغط على Change system locale وتأكد من ظبط  اللغة العربية 

1) اذا كان هذا لا يناسبك جرب الإشارة مباشرة داخل الكود  إلى  الأسماء الفعلية المستخدمة في المصنف  الخاص بك على الشكل  التالي 

  Set wsDatabase = Worksheet____1
  Set wsLists = Worksheet____3

2)  بعد إذن الأستاذ محمد صالح  و إثراءا للموضوع اليك حل اخر مع بعض الاظافات البسيطة 

لتنفيد الكود بنفس الطريقة (عند التغيير في الخلية D5)

Const Classe As String = "D5"
Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case Target.Address(0, 0)
        Case Classe
            Dim clé As String
            Dim WS As Worksheet, dest As Worksheet
            Dim lastRow As Long, i As Long, n As Long, r As Long
            Dim Rng As Variant, a As Variant, OnRng As Variant

            Set WS = Worksheet____1
            Set dest = Worksheet____3
            clé = dest.[D5].Value
            If clé = "" Then Exit Sub
            Application.ScreenUpdating = False

            If WS.AutoFilterMode Then WS.AutoFilterMode = False

            lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
            OnRng = WS.Range("B2:D" & lastRow).Value

            ReDim Rng(1 To lastRow, 1 To 3)
            ReDim a(1 To lastRow, 1 To 3)

            For i = 1 To UBound(OnRng, 1)
                If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then
                    Select Case OnRng(i, 3)
                        Case "ذكر"
                            n = n + 1
                            Rng(n, 1) = n: Rng(n, 2) = OnRng(i, 1)
                            Rng(n, 3) = WS.Cells(i + 1, "M").Value
                        Case "انثى"
                            r = r + 1
                            a(r, 1) = r: a(r, 2) = OnRng(i, 1)
                            a(r, 3) = WS.Cells(i + 1, "M").Value
                    End Select
                End If
            Next i

            If n = 0 And r = 0 Then
                MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation
            Else
                Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents
                  If n > 0 Then
                    dest.Range("A7").Resize(n, 3).Value = Application.Index(Rng, _
                                     Evaluate("ROW(1:" & n & ")"), Array(1, 2, 3))
                End If
                 If r > 0 Then
                    dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _
                                    Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3))
                End If
            End If
            Application.ScreenUpdating = True
    End Select
End Sub

او 

Sub ClassData()
    Dim WS As Worksheet, dest As Worksheet
    Dim clé As String
    Dim lastRow As Long, i As Long, n As Long, r As Long
    Dim Rng As Variant, a As Variant, OnRng As Variant

' Code..............
....................

            If r > 0 Then
               dest.Range("D7").Resize(r, 3).Value = Application.Index(a, _
                               Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3))
           End If
    End If
 Application.ScreenUpdating = True
End Sub

بالتوفيق .........

قوائم.xlsm

تم تعديل أكتوبر 8 بواسطه محمد هشام.

[عبدالله بشير عبدالله]

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

تحياتى للاستاتذة الافاضل محمد صالح ومحمد هشام  و حسين التجدى

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

على كل حال اذا كان فهمى للموضوع صحيحا فالكود التالى يلبى الطلب ان شاء الله وان كان فهمى للامر غير ذلك فعذرا من الجميع

الكود

Sub TransferStudentsByGenderAlternate22()
    Dim wsData As Worksheet
    Dim wsList As Worksheet
    Dim lastRow As Long
    Dim selectedClass As String
    Dim i As Long
    Dim rowMale As Long, rowFemale As Long
    Dim maleList As Collection, femaleList As Collection
    Dim studentName As String
    Dim studentGender As String
    Dim studentData As String
    Dim maxRows As Long
    Dim lastNumber As Long
    Dim currentNumber As Long

    Set wsData = ThisWorkbook.Sheets("قاعدة البانات")
    Set wsList = ThisWorkbook.Sheets("قوائم الفصول")

    selectedClass = wsList.Range("D5").Value

    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).row
    Set maleList = New Collection
    Set femaleList = New Collection
    For i = 8 To lastRow
        If wsData.Cells(i, 3).Value = selectedClass Then ' التحقق من الفصل
            studentName = wsData.Cells(i, 2).Value
            studentGender = wsData.Cells(i, 4).Value
            studentData = wsData.Cells(i, 13).Value ' العمود M
            If studentGender = "ذكر" Then
                maleList.Add Array(studentName, studentData)
            ElseIf studentGender = "انثى" Then
                femaleList.Add Array(studentName, studentData)
            End If
        End If
    Next i

    rowMale = 7
    rowFemale = 8
    maxRows = 34
    wsList.Range("B7:F40").ClearContents

    For i = 1 To Application.WorksheetFunction.Max(maleList.Count, femaleList.Count)
        If rowMale <= 40 Then
            If i <= maleList.Count Then
                wsList.Cells(rowMale, 2).Value = maleList(i)(0)
                wsList.Cells(rowMale, 3).Value = maleList(i)(1)
                rowMale = rowMale + 2
            End If
            If i <= femaleList.Count And rowFemale <= 40 Then
                wsList.Cells(rowFemale, 2).Value = femaleList(i)(0)
                wsList.Cells(rowFemale, 3).Value = femaleList(i)(1)
                rowFemale = rowFemale + 2
            End If
        ElseIf rowMale > 40 Then
            If i <= maleList.Count Then
                wsList.Cells(rowMale - 34, 5).Value = maleList(i)(0)
                wsList.Cells(rowMale - 34, 6).Value = maleList(i)(1)
                rowMale = rowMale + 2
            End If
            If i <= femaleList.Count Then
                wsList.Cells(rowFemale - 34, 5).Value = femaleList(i)(0)
                wsList.Cells(rowFemale - 34, 6).Value = femaleList(i)(1)
                rowFemale = rowFemale + 2
            End If
        End If
    Next i
    currentNumber = 1
    For i = 7 To 40
        If wsList.Cells(i, 2).Value <> "" Then
            wsList.Cells(i, 1).Value = currentNumber
            currentNumber = currentNumber + 1
        End If
    Next i
    For i = 7 To 40
        If wsList.Cells(i, 5).Value <> "" Then
            wsList.Cells(i, 4).Value = currentNumber
            currentNumber = currentNumber + 1
        End If
    Next i
End Sub

الملف

Microsoft Excel Worksheet جديد (3).xlsb

تم تعديل أكتوبر 8 بواسطه عبدالله بشير عبدالله

[بلانك]

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

بنين وبنات.bmp

[حسين النجدى]

المقصود الذكور فى صف والاناث فى صف 

ثانيا خطأ ثانى الفصل لو عدده  مثلا 70 تلاميذ بيكتبهم تحت المفروض يحتويهم

 

تم تعديل أكتوبر 8 بواسطه حسين النجدى

[أ / محمد صالح]

13 ساعات مضت, حسين النجدى said:

اسف على الاطاله تغير اسم الشيت من اسم الصفحه تحت

للأسف اسم الشيت مكتوب خطأ بالهاء وليس بالتاء المربوطة

يجب تطابق الاسم في الكود مع الاسم في الشيت

بالتوفيق

[عبدالله بشير عبدالله]

4 ساعات مضت, بلانك said:

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

 

يفترض فتح موضوع جديد  ولكن بما انه نفس الملف مع تعديل في نفس الكود 

ذكور ثم انات.xlsb

[بلانك]

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

ذكور ثم انات -2.xlsb

[محمد هشام.]

8 ساعات مضت, عبدالله بشير عبدالله said:

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

بارك الله فيك اخي @عبدالله بشير عبدالله  فعلا لم انتبه لهدا 

 

 

[عبدالله بشير عبدالله]

منذ ساعه, محمد هشام. said:

بارك الله فيك اخي @عبدالله بشير عبدالله  فعلا لم انتبه لهدا 

 

 وفيك بارك الله ,اعلم ذلك والا ما قمت انت والاستاذ محمد صالح  يكفى وزيادة 

 لك وافر  التقدير الاحترام 

[محمد هشام.]

 بارك الله فيكم جميعا كما تم التنويه سابقا لإثراء الموضوع لا أقل ولا أكثر

رغم ان التعليق الأخير للأخ @حسين النجدى  ( مثلا 70 تلاميذ بيكتبهم تحت المفروض يحتويهم  )  هو كدالك غير مفهوم بالنسبة لي 

يمكننا تعديل الكود المقترح سابقا ليقوم بنسخ  الذكور فى صف والاناث فى صف مع دمج الكود في حدث الشيت ليتم تنفيده عند التغيير سواءا في الجدول 1 أو  2   ونسخ البيانات للمكان المناسب

Const Classe As String = "D5"
Sub FilterClassData()
    Dim clé As String, OnRng As Variant
    Dim WS As Worksheet, dest As Worksheet
    Dim lastRow As Long, i As Long, r As Long
    Dim male As Long, female As Long
    

    Set WS = ThisWorkbook.Sheets("قاعدة البيانات")
    Set dest = ThisWorkbook.Sheets("قوائم الفصول")
    clé = dest.Range(Classe).Value
    If clé = "" Then Exit Sub
    Application.ScreenUpdating = False

    If WS.AutoFilterMode Then WS.AutoFilterMode = False
    
    lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    OnRng = WS.Range("B2:D" & lastRow).Value

    ReDim a(1 To lastRow, 1 To 3)
    r = 0: male = 0: female = 0
    For i = 1 To UBound(OnRng, 1)
        If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then
            r = r + 1
            a(r, 1) = r
            a(r, 2) = OnRng(i, 1)
            a(r, 3) = WS.Cells(i + 1, "M").Value
            
            Select Case OnRng(i, 3)
                Case "ذكر"
                    male = male + 1
                Case "انثى"
                    female = female + 1
            End Select
        End If
    Next i

    If r = 0 Then
        MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation
    Else
        Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents
        If r <= 34 Then
            dest.Range("A7").Resize(r, 3).Value = Application.Index(a, _
                                 Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3))
        Else
            dest.Range("A7").Resize(34, 3).Value = Application.Index(a, _
                                 Evaluate("ROW(1:34)"), Array(1, 2, 3))
            dest.Range("D7").Resize(r - 34, 3).Value = Application.Index(a, _
                                 Evaluate("ROW(35:" & r & ")"), Array(1, 2, 3))
        End If
        MsgBox "عدد الذكور: " & male & vbCrLf & "عدد الإناث: " & female, vbInformation
    End If
    
    Application.ScreenUpdating = True
End Sub

 

'( D5 أو D87 )تنفيد الكود عند التغيير في خلايا إسم الفصل

Const Classe1 As String = "D5"
Const Classe2 As String = "D87"
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet, dest As Worksheet, destRng As Range, MaxRows As Long, _
    lastRow As Long, i As Long, r As Long, OnRng As Variant, a As Variant, clé As String

    Select Case Target.Address(0, 0)
        Case Classe1, Classe2
            Set WS = ThisWorkbook.Sheets("قاعدة البيانات")
            Set dest = ThisWorkbook.Sheets("قوائم الفصول")

            If Target.Address(0, 0) = Classe1 Then
                clé = dest.Range(Classe1).Value
                Set destRng = dest.Range("A7")
                MaxRows = 40
            ElseIf Target.Address(0, 0) = Classe2 Then
                clé = dest.Range(Classe2).Value
                Set destRng = dest.Range("A89")
                MaxRows = 122
            End If

            If clé = "" Then Exit Sub
            Application.ScreenUpdating = False

            If WS.AutoFilterMode Then WS.AutoFilterMode = False
            lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
            OnRng = WS.Range("B2:D" & lastRow).Value

            ReDim a(1 To lastRow, 1 To 3)
            r = 0

            For i = 1 To UBound(OnRng, 1)
                If OnRng(i, 2) = clé And Len(OnRng(i, 1)) > 0 Then
                    r = r + 1
                    a(r, 1) = r
                    a(r, 2) = OnRng(i, 1)
                    a(r, 3) = WS.Cells(i + 1, "M").Value
                End If
            Next i

            If r = 0 Then
                MsgBox "لا توجد بيانات للفصل " & clé & " على " & WS.Name, vbExclamation
            Else
                If Target.Address(0, 0) = Classe1 Then
                    Union(dest.Range("A7:C40"), dest.Range("D7:F40")).ClearContents
                ElseIf Target.Address(0, 0) = Classe2 Then
                    Union(dest.Range("A89:C122"), dest.Range("D89:F122")).ClearContents
                End If

                If r <= 34 Then
                    destRng.Resize(r, 3).Value = Application.Index(a, _
                                         Evaluate("ROW(1:" & r & ")"), Array(1, 2, 3))
                Else
                    destRng.Resize(34, 3).Value = Application.Index(a, _
                                         Evaluate("ROW(1:34)"), Array(1, 2, 3))
                    dest.Range("D" & destRng.Row).Resize(r - 34, 3).Value = Application.Index(a, _
                                         Evaluate("ROW(35:" & r & ")"), Array(1, 2, 3))
                End If
            End If
    End Select
    Application.ScreenUpdating = True
End Sub

 

بيانات الفصول.xlsb

[عبدالله بشير عبدالله]

2 ساعات مضت, بلانك said:

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

 

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

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

[بلانك]

شكرا عبدالله بشير عبدالله جاري رفع ملف جديد بالمطلوب داخل الملف بموضوع جديد

تم تعديل أكتوبر 8 بواسطه بلانك