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

السلام عليكم و رحمة الله اليك الملف ملف1.xlsm

السلام عليكم و رحمة الله صراحة لم اطلع على الملف الثانى ارجو ان يكون هذا الكود التالى هو المقصود ملحوظة : قم بانشاء ورقة جديدة سمها Colln Sub Collection() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, LS As Long Set ws = Sheets("Colln") LR = ws.Range("F" & Rows.Count).End(3).Row For Each Sh In Worksheets(Array("أدب عربي1", _ "أدب عربي2", "أدب عربي3", "أدب عربي4")) LS = Sh.Range("F" & Rows.Count).End(3).Row Sh.Range("A1:I" & LS).Copy ws.Range("A" & LR).PasteSpecial xlPasteAll LR = LR + LS Next Application.CutCopyMode = False End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub AddRow() Selection.EntireRow.Insert , xlFormatFromLeftOrAbove End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub Summing() Dim C As Range, i As Long Dim a As Integer, b As Integer i = 3 Do While i <= 4 a = Range("E" & i): b = Range("F" & i) For Each C In Range("A3:A9") If C.Value >= a And C.Value <= b Then k = k + C.Offset(0, 1) Range("G" & i) = k End If Next k = 0 i = i + 1 Loop End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub ReArrange() Dim Arr, Rtb, Tmp Dim WF As Object Dim x As Integer, i As Long, p As Long Set WF = WorksheetFunction Arr = Range("B2:C8").Value Rtb = Array("السابعة", "السادسة", "الخامسة", _ "الرابعة", "الثالثة", "الثانية", "الاولى") ReDim Tmp(1 To UBound(Arr, 1), 2) For i = LBound(Rtb) To UBound(Rtb) Tmp(i + 1, 1) = Replace(Arr(i + 1, 2), Arr(i + 1, 2), Rtb(i)) Tmp(i + 1, 0) = WF.Index(Range("B2:C8"), WF.Match(Rtb(i), _ Range("C2:C8"), 0), 1) Next Range("B2").Resize(UBound(Tmp, 1), 2).Value = Tmp End Sub

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

و عليكم السلام و رحمة الله ضع الكود التالى فى حدث الفورم Private Sub CommandButton1_Click() Dim Arr, Cond1, Cond2, Cond3 Dim Tmp, p Arr = Range("A2:B9") Cond1 = Me.TextBox1.Value Cond2 = Me.TextBox2.Value Cond3 = Me.TextBox3.Value If Cond1 = "" Or Cond2 = "" Or Cond3 = "" Then MsgBox "asdfghjkl" Exit Sub End If ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) If Arr(i, 2) = Cond1 Or Arr(i, 2) = Cond2 Or Arr(i, 2) = Cond3 Then p = p + 1 For j = 1 To 2 Tmp(p, j) = Arr(i, j) Next End If Next With Me.ListBox1 .Clear .AddItem .List = Tmp End With End Sub

السلام عليكم و رحمة الله ضع الكودين الآتيين فى حدث الفورم Private Sub CommandButton1_Click() Dim ws As Worksheet, Knd As String Dim x As Integer, Trgt As Range Set ws = Sheets("ورقة1") If Me.ComboBox1.Value = "" Or Me.TextBox1.Value = "" Then MsgBox "يرجى استكمال البيانات" Exit Sub End If Knd = Me.ComboBox1.Value x = WorksheetFunction.Match(Knd, ws.Range("A1:F1"), 0) Set Trgt = ws.Cells(2, x) Trgt.Value = Trgt.Value + Me.TextBox1.Value Me.ComboBox1.Value = "" Me.TextBox1.Value = "" End Sub Private Sub UserForm_Initialize() For Each c In Range("A1:F1") Me.ComboBox1.AddItem c Next End Sub

السلام عليكم و رحمة الله اليك شرح الكود المطلوب ارجو ان اكون قد وفقت Sub LastTest() '-------------------- Dim i As Long, ws As Worksheet, Rng As Range Dim C As Range, p As Integer, x Dim Shp As Shape, Nam As String Set ws = Sheets("Sheet2") Application.ScreenUpdating = False Range("AO5:BB100") = "" ' مسح النطاق الذى سوف يتم ارسال بيانات التلاميذ الضعاف Set Shp = ws.Shapes(Application.Caller) ' تعريف الشكل حسب العنوان المكتوب عليه Nam = Shp.TextEffect.Text ' الاسم المكتوب على الشكل ws.Range("AQ1") = " الطلاب الضعاف اقل من 65 % ل" & Nam ' عبارة تكتب عقب الضغط على اى زر حسب الشهر p = 4 ' لعد التلاميذ الضعاف بدلا من الصفر يعنى i = 5 ' اول صف سوف يتم العمل عليه Do While i <= 70 ' آخر صف سوف يتم العمل عليه حسب المرفق و يم تغييره بسهولة With ws Select Case Nam ' الاعمدة التى سوف يتم العمل عليها حسب اسم الشهر المكتوب على الزر Case "شهر 10" x = Array(1, 2, 3, 4, 5, 6, 7, 11, 15, 19, 23, 27, 31, 35) Case "شهر 11" x = Array(1, 2, 3, 4, 5, 6, 8, 12, 16, 20, 24, 28, 32, 36) Case "شهر 12" x = Array(1, 2, 3, 4, 5, 6, 9, 13, 17, 21, 25, 29, 33, 37) Case Else End Select For j = LBound(x) To UBound(x) ' عدد الاعمدة المطلوبة للعمل عليها و تكون مصفوفة Set Rng = .Cells(i, x(j)) ' التعريف بالنطاق و جعل كل صف على حدة كمصوفة مستقلة بذاتها For Each C In Rng ' كل خلية فى هذا النطاق y = .Cells(4, x(j)) * 0.65 ' شرط النجاح If .Cells(i, x(j)) < y Then ' اذا كان الشرط غير متوافر m = m + 1 ' عد مواد الرسوب اقل من 65% If m > 1 Then GoTo 88: ' تكفى مادة واحدة ليبدأ للعمل عليها p = p + 1 ' العد For a = 0 To 13 ' عدد الخلايا التى سيتم ترحيل البيانات اليها .Cells(p, a + 41) = .Cells(i, x(a)) ' ترحيل البيانات .Cells(p, 41) = p - 4 ' مسلسل للتلاميذ الضعاف Next End If Next Next End With 88: m = 0 i = i + 1 Loop End Sub

السلام عليكم و رحمة الله توجد مشاركة بتاريخ سابق تم استخدام مشابه لملفك تقريبا و بنسبة كبيرة و لكن الملف القديم كان اكثر تنظيما من الملف الحالى و لكنى سأرسل اليك الملف المشابه ربما يتوفق تماما مع طلبك هذا و الله ولى التوفيق اليك الملف الطلاب اقل من 65.xlsm

السلام عليكم و رحمة الله اخى الكريم الدالة المعرفة تعمل عندى بمنتهى الكفاءة و لا ادرى سبببا للخلل المرفق مع المشاركة السابقة اليك الملف ذاته المرسل مع المشاركة الاولى بعد اضافة الدالة المعرفة اختصار معادلة1.xlsm

السلام عليكم و رحمة الله استخدم هذه الدالة المعرفة عليك بتحديد الصف الاول الذى سوف يتم جمعه Rng و من ثم استخراج النسبة المحددة و السحب لاسفل Function AllPerc(Rng As Range) As Double Dim x As Integer, y x = WorksheetFunction.Sum(Rng.Value) If x >= 8001 Then: y = x * 0.045 '-------------------- ElseIf x >= 7501 Then: y = x * 0.0425 '-------------------- ElseIf x >= 7001 Then: y = x * 0.0375 '-------------------- ElseIf x >= 6001 Then: y = x * 0.03 '-------------------- ElseIf x >= 5501 Then: y = x * 0.025 '-------------------- ElseIf x >= 5001 Then: y = x * 0.0175 '-------------------- ElseIf x >= 4501 Then: y = x * 0.015 '-------------------- ElseIf x >= 4001 Then: y = x * 0.01 '-------------------- ElseIf x >= 3001 Then: y = x * 0.005 '-------------------- Else y = 0 End If AllPerc = y End Function

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

السلام عليكم و رحمة الله اجعل الكود هكذا Sub CallData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, y As Long Dim C As Range, Temp() Dim Counter As Long Set ws = Sheets("اعداد قوائم المدرسة") t = Timer Application.ScreenUpdating = False '----------------- On Error Resume Next ws.Range("A3:L1000").ClearContents For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) LR = Sh.Range("B" & Rows.Count).End(3).Row Counter = Counter + LR Next '----------------- ReDim Preserve Temp(Counter, 12) y = 0 For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) For Each C In Sh.Range("B3:B" & LR) If Len(C.Value) > 0 Then Temp(y, 0) = y Temp(y, 1) = C.Value Temp(y, 2) = C.Offset(0, 1) Temp(y, 3) = C.Offset(0, 2) Temp(y, 4) = C.Offset(0, 3) Temp(y, 5) = C.Offset(0, 4) Temp(y, 6) = C.Offset(0, 5) Temp(y, 7) = C.Offset(0, 6) Temp(y, 8) = C.Offset(0, 7) Temp(y, 9) = C.Offset(0, 8) Temp(y, 10) = C.Offset(0, 9) Temp(y, 11) = C.Offset(0, 10) y = y + 1 End If Next Next '----------------- If y > 0 Then ws.Range("A2").Resize(y, UBound(Temp, 2)).Value = Temp '----------------- Application.ScreenUpdating = True MsgBox Round(Timer - t, 2) End Sub

السلام عليكم و رحمة الله استخدم هذا الكود Sub Get_AbsDay() Dim ws As Worksheet, LR As Long Dim I As Long, C As Range, x As Integer Dim A As String, B As String, Kod As String Dim p As Integer, q As Integer Set ws = Sheets("Sheet1") ws.Range("R8:U8") = "" ws.Range("R10:U10") = "" '--------------------- LR = ws.Range("B" & Rows.Count).End(3).Row Kod = ws.Range("N6").Value p = 17 q = 17 A = "أ" B = "غ" I = 2 Do While I <= LR If ws.Cells(I, 1) = Kod Then ws.Range("N8").Value = ws.Cells(I, 2).Value x = ws.Cells(I, 1).Row For Each C In ws.Range(ws.Cells(x, 3), ws.Cells(x, 10)) If C.Value = A Then p = p + 1 ws.Cells(8, p).Value = ws.Cells(2, C.Column).Value ElseIf C.Value = B Then q = q + 1 ws.Cells(10, q).Value = ws.Cells(2, C.Column).Value End If Next End If I = I + 1 Loop End Sub