سليم حاصبيا

جرب هذا الملف الكود مرفق 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

Option Explicit Sub give_solotion() Dim lr As Integer, col, i, k, moth As Integer Dim My_date As Date Dim First, Sec As Worksheet Set First = Sheets("السجل"): Set Sec = Sheets("المتاخرين") Application.ScreenUpdating = False lr = First.Cells(Rows.Count, 1).End(3).Row: If lr < 2 Then lr = 2 First.Range("a2:xfd1000").Interior.ColorIndex = 0 For i = 2 To lr col = First.Range("xfd" & i).End(xlToLeft).Column For k = 3 To col Step 2 My_date = First.Cells(i, k) moth = Month(My_date) If moth = Month(Date) And My_date < Date _ And First.Cells(i, k).Offset(0, -1) = "" Then First.Cells(i, k).Interior.ColorIndex = 3 First.Cells(i, 1).Interior.ColorIndex = 3 End If Next Next Translate_Data Application.ScreenUpdating = True End Sub Sub Translate_Data() Dim lr As Integer, col, i, k, m, x, moth As Integer Dim My_date As Date Dim First, Sec As Worksheet Dim arr() Set First = Sheets("السجل"): Set Sec = Sheets("المتاخرين") lr = First.Cells(Rows.Count, 1).End(3).Row: If lr < 2 Then lr = 2 Sec.Range("a2:M1000").ClearContents '============================ For i = 2 To lr col = First.Range("xfd" & i).End(xlToLeft).Column For k = 1 To col Step 2 If First.Cells(i, k).Interior.ColorIndex = 3 Then ReDim Preserve arr(1 To x + 1) arr(x + 1) = First.Cells(i, k) x = x + 1 End If Next If x = 0 Then m = m - 1: GoTo 1 Sec.Cells(m + 2, 1).Resize(1, x) = arr 1: Erase arr: x = 0 m = m + 1 Next '============================= End Sub جرب هذا الملف اضفط فقط على الزر في الصفحة 2 الكود مرفق تم التعديل على الاعمدة (ازالة الاعمدة الفارغة) المتأخرين عن التسديد salim.rar

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

ربما ينفع هذا الملف انظر الى الصفحة Salim Loan salim.rar

ارفع نموذجا مبسطاً عما تريد لا يمكن العمل على التخمين

اذا كانت نتيجة المعادلة #value هذا يعني : المعادلة هي معادلة صفيف( Formula Array) و يستطيع اكسل التعرف عليها بواسطة (Ctrl+Shift+Enter) *بعد كتابة المعادلة : مع الاستمرا ر بالضغط على مفتاحي Ctrl+Shift تقوم بنقر مفتاح Enter لتنفيذ المعادلة حيث ان المعادلة جاهزة(قمت بكتابتها) لذا: 1-حدد الخلية التي تحتوي على المعادلة 2- أضفط على المفتاح F2 فتظهر لك المعادلة في هذه الحلية 3-مع الاستمرا ر بالضغط على مفتاحي Ctrl+Shift تقوم بنقر مفتاح Enter لتنفيذ المعادلة 4-اسحب المعادلة على باقي الخلايا

العمل بالمعادلات بواسطة الفاصلة أو الفاصلة المنقوطة تتم حسب اعدادات الجهاز و يمكن التحكم بها عن طريق Control Panel ااذا بم تعمل المعادلة بواسطة الفاصلة يمكن التفيير الى الفاصلة المنقوطة (Ctrl+Shift+Enter) نعني ان المعادلة هي معادلة صفيف( Formula Array) و يستطيع اكسل التعرف عليها بواسطة (Ctrl+Shift+Enter) مع الاستمرا ر بالضغط على مفتاحي Ctrl+Shift تقوم بنقر مفتاح Enter لتنفيذ المعادلة

جرب هذا الملف Tansiq.rar

ربما يكون الحل x Salim.rar

ربما تنفع هذه المعادلة في الخلية AV10 ,و اسجب نزولاً استعملها مع (Ctrl+Shift+Enter) وليس Enter وحدها =IFERROR(INDEX($CG$4:$CG$100,MATCH(AS10&AT10&AU10,$CD$4:$CD$100&$CE$4:$CE$100&$CF$4:$CF$100,0)),"")

ربما يكون الحل هنا تم جماية خلايا المغادلات لعدم العبث بها عن طريق الخطأ جلب بيانات بين تاريخين SALIM.rar

أليك الحل للكومبو 3 و4 كمبوبوكس بطريقتين3 Salim.rar

و هذا ما يقوم به البرمامج

ربما يكون الحل 111 salim.rar

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

تم معالجة الامر مع اضافة قائمة منسدلة مطاطة للتاريخ دون تكرار book Salim.rar

غلطة مطبعية في الكود فقط تم التصحيح كمبوبوكس بطريقتين Salim 1.rar

مرفق الحل كمبوبوكس بطريقتين Salim.rar

يلزم هذا الكود Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) ComboBox1.Clear col = Sheets("صفحة1").Cells(2, Columns.Count).End(1).Column For i = 1 To col ComboBox1.AddItem Cells(2, i) Next End Sub Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) ComboBox1.Clear col = Sheets("صفحة1").Cells(2, Columns.Count).End(1).Column For i = 1 To col ComboBox2.AddItem Cells(2, i) Next End Sub

جرب هذا الملف mal_femel.rar

اذا كان حجم البيانات كبيراً يمنك استعمال الماكرو Option Explicit Sub Transpose_range() If ActiveSheet.Name <> "Salim" Then Exit Sub Dim my_rg As Range Dim Ro, Col As Integer Range("b9:c100000").Clear Ro = 3 Col = ActiveSheet.Cells(3, Columns.Count).End(1).Column With Cells(9, 2).Resize(Col - 1, 2) .Value = Application.Transpose(Range(Cells(Ro, 2), Cells(4, Col))) .Borders.LineStyle = 1 .SpecialCells(4).EntireRow.Delete End With End Sub الملف مرفق الورقة Salim Transpose_Data.rar

لم افهم عليك ما تريد اي خلية تريد ان تدرج فيها فيمة الكومبو واي كومبو من الاثنين و باي طريقة من الاثنتين

جرب هذا الماكرو Option Explicit Sub del_2017() Dim My_rg, My_cel As Range Set My_rg = Range("b1").CurrentRegion.Columns(1) For Each My_cel In My_rg.Cells My_cel = Replace(Replace(My_cel, "2017", ""), "*", "") Next End Sub

الكود الازم لهذه الحالة Private Sub ComboBox1_AfterUpdate() Sheets("صفحة 2").Range("d2") = ComboBox1.Value End Sub Private Sub CommandButton1_Click() Sheets("صفحة 2").Range("e2") = ComboBox2.Value End Sub

Talween_Bot.rar