نجوم المشاركات

وعليكم السلام جرب هذا الحل قوائم التلاميذ معدل.xlsm

اظن ان الكود المقترح من الاستاد @حسونة حسين يشتغل بشكل جيد على العموم جرب هدا Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim tmp1 As Object, tmp2 As Object, c As Variant Dim n As Variant, a As Variant, b As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow > 1 Then .Range("C2:E" & Irow).ClearContents End If arr = .Range("A2:B" & Irow).Value Set tmp1 = CreateObject("Scripting.Dictionary") Set tmp2 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr, 1) If arr(i, 1) <> "" Then tmp1(arr(i, 1)) = True If arr(i, 2) <> "" Then tmp2(arr(i, 2)) = True Next i For Each n In tmp1 If tmp2.exists(n) Then c = cnt(c, n) tmp2.Remove n Else a = cnt(a, n) End If Next n For Each n In tmp2 b = cnt(b, n) Next n If Not IsEmpty(a) Then [C2].Resize(UBound(a), 1).Value = WorksheetFunction.Transpose(a) If Not IsEmpty(b) Then [D2].Resize(UBound(b), 1).Value = WorksheetFunction.Transpose(b) If Not IsEmpty(c) Then [E2].Resize(UBound(c), 1).Value = WorksheetFunction.Transpose(c) Application.ScreenUpdating = True End With End Sub Function cnt(arr As Variant, Value As Variant) As Variant If IsEmpty(arr) Then ReDim arr(1 To 1) arr(1) = Value Else ReDim Preserve arr(1 To UBound(arr) + 1) arr(UBound(arr)) = Value End If cnt = arr End Function مقارنة 3.xlsb

وعليكم السلام ورحمة الله وبركاته 🙂 كتبت لك كود يراعي أن يكون المبلغ المدفوع أقل من أو يساوي المدفوع وكذلك الكود يكمل على الدفع السابق في حال أنه تم دفع جزء من المبلغ سابقا.. تفضل هذا هو الكود : Private Sub Command6_Click() Dim PayedAmount As Double, Amount As Double, Remaining As Double Dim RS As DAO.Recordset Dim SQl As String PayedAmount = Nz(Me.Text4, 0) If PayedAmount = 0 Then MsgBox "أدخل المبلغ": Exit Sub Remaining = Nz(DSum("rest", "Table1", "cod = " & [Forms]![Form1]![sh]), 0) If PayedAmount > Remaining Then MsgBox "المبلغ المدفوع أكبر من المبلغ المتبقي للسداد": Exit Sub SQl = "SELECT * FROM Table1 WHERE Table1.rest > 0 AND Table1.cod = " & [Forms]![Form1]![sh] Set RS = CurrentDb.OpenRecordset(SQl) Do While Not RS.EOF RS.Edit If PayedAmount >= RS.Fields("rest") Then Amount = RS.Fields("rest").Value RS.Fields("pye").Value = RS.Fields("pye").Value + RS.Fields("rest") If RS.Fields("rest").Value = 0 Then RS.Fields("valider").Value = True PayedAmount = PayedAmount - Amount Else RS.Fields("pye").Value = RS.Fields("pye").Value + PayedAmount If RS.Fields("rest").Value = 0 Then RS.Fields("valider").Value = True PayedAmount = 0 End If RS.Update If PayedAmount = 0 Then Exit Do RS.MoveNext Loop Me.w.Requery MsgBox "Done" Set RS = Nothing End Sub pye.accdb

السلام عليكم ورحمة الله وبركاته بعد اذن استاذنا ومعلمنا محمد هشام وحسب فهمى للطلب الكود Sub test() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim years As Long, months As Long, days As Long Dim totalMonths As Long Dim data As Variant Dim result() As Variant Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row data = ws.Range("A3:W" & lastRow).Value ReDim result(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) If data(i, 2) = "" Then result(i, 1) = "" Else years = IIf(IsNumeric(data(i, 23)), data(i, 23), 0) months = IIf(IsNumeric(data(i, 22)), data(i, 22), 0) days = IIf(IsNumeric(data(i, 21)), data(i, 21), 0) totalMonths = (years * 12) + months + Int(days / 30) Select Case True Case data(i, 14) <> "" result(i, 1) = "كبير" Case data(i, 13) <> "" If totalMonths >= 12 Then result(i, 1) = "الاول أ" Else result(i, 1) = "الاول ب" End If Case data(i, 12) <> "" If totalMonths >= 36 Then result(i, 1) = "الثاني أ" Else result(i, 1) = "الثاني ب" End If Case data(i, 11) <> "" If totalMonths >= 72 Then result(i, 1) = "الثالث أ" ElseIf totalMonths >= 36 Then result(i, 1) = "الثالث ب" Else result(i, 1) = "الثالث ج" End If Case data(i, 10) <> "" If totalMonths >= 24 Then result(i, 1) = "الرابع أ" Else result(i, 1) = "الرابع ب" End If End Select End If Next i ws.Range("X3:X" & lastRow).Value = result Application.ScreenUpdating = True End Sub الملف تحويل من اجر اساسي الي اجر وظيفي (2).xlsb

السلام عليكم استادي الفاضل Moosak جزاك الله خيرا وزادك من فضله هذا هو المطلوب بالظبك الف الف شكر

تفضل 🙂 : علم على المواد التي تود إظهارها Private Sub Report_Open(Cancel As Integer) Dim WidthEach As Long: WidthEach = 4560 Dim x As Integer: x = 4 Me.Ar.Visible = [Forms]![Form1]![Ar] Me.En.Visible = [Forms]![Form1]![En] Me.Dr.Visible = [Forms]![Form1]![Dr] Me.Si.Visible = [Forms]![Form1]![Si] If [Forms]![Form1]![Ar] = False Then Me.Ar.Width = 0: x = x - 1 If [Forms]![Form1]![En] = False Then Me.En.Width = 0: x = x - 1 If [Forms]![Form1]![Dr] = False Then Me.Dr.Width = 0: x = x - 1 If [Forms]![Form1]![Si] = False Then Me.Si.Width = 0: x = x - 1 If x > 0 Then WidthEach = WidthEach / x If Me.Ar.Visible = True Then Me.Ar.Width = WidthEach If Me.En.Visible = True Then Me.En.Width = WidthEach If Me.Dr.Visible = True Then Me.Dr.Width = WidthEach If Me.Si.Visible = True Then Me.Si.Width = WidthEach Else: Me.Class.Width = Class.Width + WidthEach End If End Sub درجات الطلاب.accdb

INDEX او MATCH وحدهما لا تسمح لك بجمع نطاق متعدد الأعمدة بناءا على شروط معينة في نطاقات أخرى كما هو الحال مع SUMPRODUCT او SUMIFS لانها غالبا تستخدم لاستخراج قيمة واحدة من نطاق معين بشرط تطابق صف وعمود وليس لجمع نطاق كامل اما ادا كنت بحاجة الى بدائل تنفد نفس المهمة يمكنك استخدام احدى المعادلات التالية =SUMPRODUCT((($O$14:$O$17=I14)*($B$4:$B$7=J14)), MMULT(($C$4:$E$7), TRANSPOSE(COLUMN($C$4:$E$4)^0))) او =SUM(FILTER($C$4:$E$7, ($O$14:$O$17=I14)*($B$4:$B$7=J14))) او =SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$C$4:$C$7) + SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$D$4:$D$7) + SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$E$4:$E$7) او =SUMIFS($C$4:$C$7, $O$14:$O$17, I14, $B$4:$B$7, J14) + SUMIFS($D$4:$D$7, $O$14:$O$17, I14, $B$4:$B$7, J14) + SUMIFS($E$4:$E$7, $O$14:$O$17, I14, $B$4:$B$7, J14) Officena 2.xlsx

بعد إذن أساتذتي الكرام تفضل أخي الكريم فصل و تجميع و تفقيط Book(1).xlsm

بعد اذن استاذنا محمد صالح ومن خلال البحث في المنتدى =IF(ISNUMBER(FIND("."; Sheet1!A8)); VALUE(MID(Sheet1!A8; FIND("."; Sheet1!A8)+1; LEN(Sheet1!A8))); 0) =IF(ISNUMBER(FIND("."; Sheet1!A8)); VALUE(LEFT(Sheet1!A8; FIND("."; Sheet1!A8)-1)); VALUE(B8)) =MOD(SUM(A8:A12); 100) =SUM(B8:B12) + INT(SUM(A8:A12) / 100) الملف Book2.xlsx

تفضل اخى مقارنة.xlsb

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

وعليكم السلام ورحمه الله وبركاته تفضل رسالة واتساب عام محدث7.xlsm

@Mohamed Hicham لماذا تستخدم الحلقة التكرارية وخاصية اختيار الملفات ؟ من شانه ان يجعل الكود بطيء ، دائما نلجا الى الفلترة او الفلترة المتقدمة لسرعتها خصوصا ان بيانات الاخ tahar صغيرة اما اذا كانت البيانات ضخمة عندها نستخدم الحلقة التكرارية مع المصفوفات لتسريع الكود. مجرد ملاحظة فقط ..تحياتي .

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي الكريم يمكنك وضع الكود التالي وفلترة العمود بعشرة اعداد دفعة واحدة قابلة للزيادة . Sub Filter_() Dim Criteria_MH(100) As String Dim i As Integer Application.ScreenUpdating = False Sheets("ارقام الفلترة").Activate Range("A2:A12").Select For i = 0 To Selection.Count Criteria_MH(i) = Selection(i) Next Sheets("الجدول").Range("A3:A100").AutoFilter Field:=1, Criteria1:=Criteria_MH, Operator:=xlFilterValues Sheets("الجدول").Activate Application.ScreenUpdating = True End Sub tahar-MH.xlsm