أريد حل لهذه المشكلة

[EL_Kashef]

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

 

لو سمحتم عاوز حل للمشكلة دى

بمناسبة اقتراب العام الدراسى الجديد

عملت برنامج صغير لعمل قوائم الفصول

عاوز أرحل الطلاب كل واحد حسب الفصل بتاعه اللى يتكتب فى خانة الفصل بتاعة بيانات الطلاب

وياريت لو امكن الترتيب الابجدى كمان

واكون شاكر جدا ليكم

البرنامج كامل فى المرفقات

وفى انتظار الرد

Book2.rar

[سليم حاصبيا]

3 ساعات مضت, EL_Kashef said:

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

 

لو سمحتم عاوز حل للمشكلة دى

بمناسبة اقتراب العام الدراسى الجديد

عملت برنامج صغير لعمل قوائم الفصول

عاوز أرحل الطلاب كل واحد حسب الفصل بتاعه اللى يتكتب فى خانة الفصل بتاعة بيانات الطلاب

وياريت لو امكن الترتيب الابجدى كمان

واكون شاكر جدا ليكم

البرنامج كامل فى المرفقات

وفى انتظار الرد

Book2.rar

ارفع ملفاً(نموذجياُ حوالي 50 اسم) يحتوي على اسماء جميع التلاميد مع فصولهم والمعلومات عنهم في ورقة واحدة(هكذا يحب ان تبدأ)

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

[ابراهيم الحداد]

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

ربما هذا يفيدك

 

Lists.rar

[EL_Kashef]

أستاذنا الكبير

شكرا لك على الرد السريع

تم ارفاق الملف بعد اضافة اسماء الطلاب كما تريد

فى انتظار ردكم الكريم

Book2 2.rar

[سليم حاصبيا]

جرب هذا الملف

الكود مرفق

 

Option Explicit

Sub tanslate_data()
Dim My_Sh As Worksheet
Dim lr1, i, k, m As Integer
Dim my_rg, cel  As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
lr1 = Main.Cells(Rows.Count, "D").End(3).Row
Set my_rg = Main.Range("d12:j" & lr1)

For i = 1 To 10
m = 0
 Set My_Sh = Sheets(i & "")
  My_Sh.Range("c10:H34").ClearContents
  My_Sh.Range("j10:o34").ClearContents
  For k = 12 To lr1
  '=======================
 Select Case m
  Case Is < 25
        If Main.Cells(k, "j") = i Then
            My_Sh.Cells(m + 10, "c") = Main.Cells(k, "d")
            My_Sh.Cells(m + 10, "f") = Main.Cells(k, "g")
            My_Sh.Cells(m + 10, "g") = Main.Cells(k, "h")
            My_Sh.Cells(m + 10, "h") = Main.Cells(k, "i")
            m = m + 1
  End If
  Case Else
        If Main.Cells(k, "j") = i Then
            My_Sh.Cells(m - 15, "j") = Main.Cells(k, "d")
            My_Sh.Cells(m - 15, "m") = Main.Cells(k, "g")
            My_Sh.Cells(m - 15, "n") = Main.Cells(k, "h")
            My_Sh.Cells(m - 15, "o") = Main.Cells(k, "i")
            m = m + 1
        End If
  End Select
  Next
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

studiant_by_classes.rar

[EL_Kashef]

جارى التجربة

 

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

[EL_Kashef]

بعد التجربة

 

وإجراء بعض التعديلات البسيطة

 

الكود يعمل بكفاءة

 

فعلا هو ده اللى كنت عاوزه

 

بس كرم أخلاقك بيخلينى اطمع فى طلب كمان لو أمكن

 

ياسلام بقى لو كود ترتيب ابجدى داخل الفصول

 

يعنى بعد الترحيل

 

يتم عمل ترتيب أبجدى للأسماء

 

يبقى تمام التمام

 

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

 

يعنى واحد مستجد يجى قدام بيانات واحد باق مثلا

 

فلو فى كود لكده يبقى تمام التمام

[سليم حاصبيا]

4 ساعات مضت, EL_Kashef said:

بعد التجربة

 

وإجراء بعض التعديلات البسيطة

 

الكود يعمل بكفاءة

 

فعلا هو ده اللى كنت عاوزه

 

بس كرم أخلاقك بيخلينى اطمع فى طلب كمان لو أمكن

 

ياسلام بقى لو كود ترتيب ابجدى داخل الفصول

 

يعنى بعد الترحيل

 

يتم عمل ترتيب أبجدى للأسماء

 

يبقى تمام التمام

 

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

 

يعنى واحد مستجد يجى قدام بيانات واحد باق مثلا

 

فلو فى كود لكده يبقى تمام التمام

المشكلة ان الاسماء موجودة في خلايا مدمجة (الاعمدة D E F)مما يعيق عملية الترتيب الابجدي للتلاميذ

كي تتم عملية الابجدة يجب كتابة الاسماء في عامود واحد دون استعمال عدو الاكواد الاول(أعني الخلايا المدمجة)

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

 

[سليم حاصبيا]

جرب هذا الملف للفرز والابجدة

الكود مرفق

Sub Filter_Me(x)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sapace").Cells.Clear
With Sheets("Main")
   .Range("$B$4:$G$434").AutoFilter Field:=6, Criteria1:="=" & x
   .AutoFilter.Sort.SortFields.Add Key:=Range("C4:C434")
   .Range("b4:g434").SpecialCells(12).Copy Destination:=Sheets("Sapace").Range("b4")
   .Range("$B$4:$G$434").AutoFilter
    End With
    lrx = Sheets("Sapace").Cells(Rows.Count, "b").End(3).Row
   With Sheets(x & "")
    .Range("b5:g50").ClearContents
     .Cells(5, 2).Resize(lrx, 6).Value = Sheets("Sapace").Range("b5:g" & lrx).Value
     .Columns.AutoFit
     End With
     Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   End Sub
Sub Give_data()
For i = 1 To 10
Filter_Me (i)
Next
End Sub

 

correction_stds.rar

[EL_Kashef]

للأسف لم يظبط معى

 

جارى التعديل لإلغاء دمج الخلايا

[EL_Kashef]

تم تعديل الملف بالكامل وتم الغاء الخلايا المدمجة

أرجو منكم كود للترحيل والترتيب الأبجدى

مع مراعاة البدء بالإناث فى الفصول المشتركة

الملف الجديد فى المرفقات

 

004.rar

[سليم حاصبيا]

تفضل يا صديقي هذا اقصى ما توصلت اليه

تم تغيير اسماء الصفحات المعنية لحسن العمل مع اللغة الاجنبية(فقط اضغط على الزر في صفحة Main)

ثم تفقد باقي الصفحات

الكود (يأخذ وقتاً لانه طويل قليلاً)

Sub Filter_Me(x)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sapace").Range("b4:g200").ClearContents
    With Sheets("Main")
       .Range("$B$16:$g$434").AutoFilter Field:=6, Criteria1:="=" & x
       .AutoFilter.Sort.SortFields.Add Key:=Range("C16:C434")
       .Range("b16:g434").SpecialCells(12).Copy Destination:=Sheets("Sapace").Range("b4")
       .Range("$B$16:$g$434").AutoFilter
     End With
  Sheets("Sapace").Select
    lrx = Sheets("Sapace").Cells(Rows.Count, "b").End(3).Row
      
     Range("D4").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("D4:D" & lrx), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sapace").AutoFilter.Sort
        .Apply
    End With
    Selection.AutoFilter
  
   With Sheets(x & "")

     ro1 = .Cells(Rows.Count, "d").End(3).Row
     ro2 = .Cells(Rows.Count, "i").End(3).Row
     ro = Application.Max(ro1, ro2)
    .Range("d12:g" & ro).ClearContents
     .Range("i12:L" & ro).ClearContents
       y = Int(lrx / 2): m = 12
    For tt = 1 To 2
      Select Case m
      Case Is <= y
       .Cells(12, 4).Resize(y - 4, 4).Value = Sheets("Sapace").Range("c5:f" & y).Value
      m = y + 1
      Case Else
       .Cells(12, 9).Resize(m, 4).Value = Sheets("Sapace").Range(Cells(lrx - y, 3), Cells(lrx, 6)).Value
      End Select
        Next
      End With
     Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   End Sub
Sub Give_data()
'توزيع النلاميذ مع الابجدة الاتاث أولا
For i = 1 To 10
Filter_Me (i)
Next
End Sub

 

st distribution_with aphab femel_first.rar

[EL_Kashef]

مع كامل شكرى واحترامى لحضرتك

مع إن الكود لم يظبط معى

لكن جزاك الله عنى كل خير

كده تمام

وانا هحاول حاجات تانى لحد ما اوصل للى انا عاوزه

بكرر شكرى تانى لحضرتك

وتقبل تحياتى

[سليم حاصبيا]

5 ساعات مضت, EL_Kashef said:

مع كامل شكرى واحترامى لحضرتك

مع إن الكود لم يظبط معى

لكن جزاك الله عنى كل خير

كده تمام

وانا هحاول حاجات تانى لحد ما اوصل للى انا عاوزه

بكرر شكرى تانى لحضرتك

وتقبل تحياتى

استعمل  الملف الذي رفعتة لك 

لان اسماء الصفحات متغيرة او ربما كانت عناوين الخلايا التي تبدأ فيها البيانات عندك في الصفحة Mainمتغيرة