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

السلام عليكم  
 بعض الاقسام غير موجودة  يمكنك اظافتها وسحب المعادلة اليها
تقرير.xlsx

تم عمل البحث بالمدينة وعدم تكرار رقم البطاقة 
كروت_07.xlsb

السلام عليكم 
يمكن عن طريق رسم دائرة على الخلية
الكود  
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column > 7 And Target.Column < 31 And Target.Row > 5 Then Cancel = True Dim ws As Worksheet Set ws = ActiveSheet Dim shp As Shape For Each shp In ws.Shapes If Not Intersect(shp.TopLeftCell, Target) Is Nothing Then shp.Delete End If Next shp With ws.Shapes.AddShape(msoShapeOval, Target.Left, Target.Top, Target.Width, Target.Height) .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) End With End If End Sub الملف 
دائرة حمراء.xls
 

السلام عليكم
تم التعديل ان شاء الله
عمل احصائية.xlsm

وعليكم السلام ورحمة الله وبركانه
اضطررت الى تعديل الجدول قليلا في صفحة جدوال الشرائح 
الكود
Sub CalculateRanges() Dim wsClients As Worksheet Dim wsRanges As Worksheet Dim lastRowClients As Long Dim i As Long, j As Long, k As Long Dim count As Long Dim total As Double Dim depositValue As Double Dim rangeStart As Double Dim rangeEnd As Double Dim ranges As Variant Dim colIndex As Variant Dim infiniteRows As Variant Set wsClients = ThisWorkbook.Sheets("العملاء") Set wsRanges = ThisWorkbook.Sheets("جدوال الشرائح") lastRowClients = wsClients.Cells(wsClients.Rows.count, 1).End(xlUp).Row ranges = Array(Array(3, 7, 3), Array(10, 14, 4), Array(17, 21, 5), Array(24, 28, 6), Array(31, 35, 7)) infiniteRows = Array(7, 14, 21, 28, 35) For k = LBound(ranges) To UBound(ranges) wsRanges.Range("D" & ranges(k)(0) & ":F" & ranges(k)(1)).ClearContents For i = ranges(k)(0) To ranges(k)(1) rangeStart = wsRanges.Cells(i, "B").Value If IsInArray(i, infiniteRows) Then rangeEnd = Application.WorksheetFunction.Large(wsClients.Range("C2:C" & lastRowClients), 1) * 10 ' اعتبار القيمة ما لا نهاية Else rangeEnd = wsRanges.Cells(i, "C").Value End If count = 0 total = 0 For j = 2 To lastRowClients depositValue = wsClients.Cells(j, ranges(k)(2)).Value If depositValue >= rangeStart And depositValue <= rangeEnd Then count = count + 1 total = total + depositValue End If Next j wsRanges.Cells(i, "D").Value = count wsRanges.Cells(i, "E").Value = total Next i wsRanges.Cells(ranges(k)(1) + 1, "D").Formula = "=SUM(D" & ranges(k)(0) & ":D" & ranges(k)(1) & ")" wsRanges.Cells(ranges(k)(1) + 1, "E").Formula = "=SUM(E" & ranges(k)(0) & ":E" & ranges(k)(1) & ")" Next k End Sub Function IsInArray(valueToFind As Variant, arr As Variant) As Boolean Dim i As Long For i = LBound(arr) To UBound(arr) If arr(i) = valueToFind Then IsInArray = True Exit Function End If Next i IsInArray = False End Function الملف 
شرائح.xlsb

الله يحفظك
=IF(J15 < 0; "المبلغ ناقص"; "المبلغ كامل") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

المقصود عند دخول الورقة قائمة الاسماء  قي العمود D كلما اضفت اسما او اكثر ولو كان مكررا تجده في القائمة في الخلية
وهذا ما يقوم به الكود حاليا  عند تغيير الاسم في الخلية I6  نجد مجموع الرواتب في M6 ومجموع السلف في M7  للموظف 
اذا كانت بياناتك بسيطة فمعادلان  اما اذا كانت كبيرة فانصحك بالكود
على كل حال  اليك الحل عن طريق المعادلات ولك الخيار في استخدام ما يفيدك في عملك
DC (1).xlsx

وعليكم السلام ورحمة الله وبركانه 
الملف
____أرقام الجلوس والمناداة - 2025 الرابع.xlsm

طريقة اخرى بدالة غير مباشرة 
Function GetHyperlinkAddress(rng As Range) As String On Error Resume Next GetHyperlinkAddress = rng.Hyperlinks(1).Address End Function ثم في العمود M  نكتب   =GetHyperlinkAddress(I2) لرابط اليوتيوب
 وفي  العمود J نكتب لرابط الفيس  =GetHyperlinkAddress(J2)
الملف
qrcode1.xlsb

السلام عليكم 
اخى الفاضل
الاسباب كثيرة منها 
             ربما الإصدارين مثبتان بشكل صحيح وتوجد تعارضات بينهما 
            ربما عدم  وجود   Microsoft Forms 2.0 Object Library
ربما التحديثات التلقائية لأحد الإصدارين إلى تعطيل أو إفساد إعدادات الإصدار الآخر
على كل حال ارفاق ملف  يقفل باب ربما
في انتظار ارفاق ملفك لاصدار 2016 وهو الموجود حاليا على جهازي
لك كل الود والاحنرام

وعليكم السلام ورحمة الله وبركاته
Private Sub Workbook_Open() On Error Resume Next ThisWorkbook.Sheets("الــــــــــــــــوارد ").ScrollArea = "A1:I753" End Sub "A1:I753" هذا النطاق يمكن تعديله  وهو المسموح  الكتابه به
اذا اردت النطبيق على جداول اخرى انسخ     ThisWorkbook.Sheets("الــــــــــــــــوارد         ").ScrollArea = "A1:I753" والصقه بالكود وغير اسم الصفحة والنطاق
 
سجل.xlsb

وعليكم السلام ورحمة الله وبركانه
اولا لديك حساب المدة غير دقيق  
فمثلا  1/1/2024 - 31/12/2024 ليست 12 شهر ينقصها يوم وبكن يمكن اعتبارها 12 شهر 
20-3-2024 - 31-12-2024 ليست  9  اشهر و37 يوم كما ورد في ملفك والصحيح 9 اشهر و11 يوم
تم عمل كود يقوم بتوزيع المبلغ  على عدد الاشهر وفي حالة وجود ايام مع الاشهر يدخلها قي توزيغ الميلغ
حالات استنائية مثل حالة 11شهر و30 يوم سينم نوزيعها على 12 شهر
هذا حسب قهمى لطلبك وانمنى ان يكون الملف المرفق فيه طلبك  
الكود
Sub توزيع() Dim ws As Worksheet Dim startDate As Range, endDate As Range, amount As Range Dim i As Long, monthsDiff As Integer, extraDays As Integer Dim totalMonths As Integer, monthlyAmount As Double Dim colStart As Integer Range("H7:S12").ClearContents Set ws = ThisWorkbook.Sheets("ورقة1") Set startDate = ws.Range("D7:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) Set endDate = ws.Range("E7:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row) Set amount = ws.Range("F7:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row) colStart = 8 For i = 1 To startDate.Rows.Count If IsDate(startDate.Cells(i, 1).Value) And IsDate(endDate.Cells(i, 1).Value) Then Dim startDt As Date, endDt As Date startDt = startDate.Cells(i, 1).Value endDt = endDate.Cells(i, 1).Value monthsDiff = DateDiff("m", startDt, endDt) If Day(endDt) < Day(startDt) Then monthsDiff = monthsDiff - 1 extraDays = Day(endDt) + (Day(DateSerial(Year(endDt), Month(endDt), 0)) - Day(startDt)) Else extraDays = Day(endDt) - Day(startDt) End If If extraDays >= 30 Then monthsDiff = monthsDiff + 1 End If If IsNumeric(amount.Cells(i, 1).Value) And amount.Cells(i, 1).Value > 0 Then If monthsDiff > 0 Then monthlyAmount = amount.Cells(i, 1).Value / monthsDiff Dim j As Integer For j = 0 To monthsDiff - 1 ws.Cells(i + 6, colStart + j).Value = monthlyAmount Next j Else ws.Cells(i + 6, colStart).Value = "" End If Else ws.Cells(i + 6, colStart).Value = "" End If Else ws.Cells(i + 6, colStart).Value = "" End If Next i End Sub جدول توزيع الاقساط.xlsm
 
   

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

 
تم حذق التنسيق الشرطى من الورقة باكملها وعمل كود يقوم بتلوين الخلايا السالبة
يوجد زر لعمل ذلك
تبقى كثرة المعادلات
جرب الملف ربما يكون به بعض التحسن
حسابات محطة النخلة_٠٩٤٩٥١.xlsm

حسب طلبك بدون شاشات حوارية وغبرها يجب كنابة اسم الملف في الكود يالملف الاول  وان يكون الملفان في نقس  المسار
جرب واعلمنى ان كان هنلك اي تعديل
طبعا الملف 2 لا يوجد به تعديل
الملف1.xlsb
 

السلام عليكم 
بعد اذن استاذنا الفاضل محمد هشام
يالنسبة لسؤالك اضغط على 
Ctrl + Shift + Enter
 اطلعت على ملفك وما قام به الاستاذ محمد هشام كاقي ووافي 
ولكن التعامل مع معادلات الصفيف تحتاج الى  من ينتبه بحذر عند استخذام الملف لان ضباع الاقواس معناها نتائج خاطئة
ارفق لك ملفا  بواسطة كود يعمل تلقائيا عند الاختيار من القائمة الى جانب يقوم بتحديث القائمة اذا اضفت لها بيانا جديدا او اكثر
DC.xlsb
 

وعليكم السلام ورحمة الله وبركاته
الكود 
Sub DistributeStudents() Dim ws As Worksheet Dim lastRow As Long Dim dataRange As Variant Dim outputRange As Variant Dim rowNum As Long, colNum As Long Dim colStart As Integer, colEnd As Integer Dim totalStudents As Long, committees As Long Dim studentsPerCommittee As Long, extraStudents As Long Dim failedRows As String Const MaxStudentsPerCommittee As Long = 29 Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, 9).End(xlUp).row colStart = 11 colEnd = 30 ' Clear the output range ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).ClearContents ws.Range("I2:I" & lastRow).Interior.Color = xlNone ' إزالة أي ألوان سابقة dataRange = ws.Range("I2:J" & lastRow).Value ReDim outputRange(1 To UBound(dataRange, 1), colStart To colEnd) failedRows = "" For rowNum = 1 To UBound(dataRange, 1) totalStudents = dataRange(rowNum, 1) committees = dataRange(rowNum, 2) If committees > (colEnd - colStart + 1) Then MsgBox "عدد اللجان في الصف " & rowNum + 1 & " يتجاوز الحد الأقصى للأعمدة المتاحة!", vbExclamation Exit Sub End If If totalStudents = 0 Or committees = 0 Then For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum Else If totalStudents > committees * MaxStudentsPerCommittee Then ws.Cells(rowNum + 1, 9).Interior.Color = RGB(255, 0, 0) For colNum = colStart To colEnd outputRange(rowNum, colNum) = "" Next colNum failedRows = failedRows & (rowNum + 1) & ", " Else studentsPerCommittee = totalStudents \ committees extraStudents = totalStudents Mod committees For colNum = colStart To colStart + committees - 1 If extraStudents > 0 Then outputRange(rowNum, colNum) = studentsPerCommittee + 1 extraStudents = extraStudents - 1 Else outputRange(rowNum, colNum) = studentsPerCommittee End If Next colNum For colNum = colStart + committees To colEnd outputRange(rowNum, colNum) = "" Next colNum End If End If Next rowNum ws.Range(ws.Cells(2, colStart), ws.Cells(lastRow, colEnd)).Value = outputRange If failedRows <> "" Then failedRows = Left(failedRows, Len(failedRows) - 2) ' إزالة الفاصلة الأخيرة MsgBox "تم توزيع الطلاب على اللجان بنجاح! ولكن لم يتم توزيع الطلاب في الصفوف التالية بسبب تجاوز الحد الأقصى لعدد الطلبة على عدداللجان: " & vbCrLf & failedRows, vbExclamation Else MsgBox "تم توزيع الطلاب على اللجان بنجاح!", vbInformation End If End Sub الملف
 التوزيع.xlsb
 

وعليكم السلام ورحمة الله وبركانه
لم نوضح لنا مكان كتابة النتائج النهائية وكيف ترغب شكلها النهائي
في الملف العمود  c كلمة نطايق نعنى ان لها مثيل في العمودين d-e
وفي العمود f  كلمة نطايق نعنى ان لها مثيل في العمودين A - B
الكود
Sub CompareTablesInOneSheet() Dim ws As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long Dim j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row lastRow2 = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row ws.Range("C2:C" & lastRow1).ClearContents ws.Range("F2:F" & lastRow2).ClearContents For i = 2 To lastRow1 For j = 2 To lastRow2 If ws.Cells(i, 1).Value = ws.Cells(j, 4).Value And ws.Cells(i, 2).Value = ws.Cells(j, 5).Value Then ws.Cells(i, 3).Value = "متطابق" ws.Cells(j, 6).Value = "متطابق" Exit For End If Next j If ws.Cells(i, 3).Value <> "متطابق" Then ws.Cells(i, 3).Value = "غير متطابق" End If Next i For j = 2 To lastRow2 If ws.Cells(j, 6).Value <> "متطابق" Then ws.Cells(j, 6).Value = "غير متطابق" End If Next j MsgBox "تم مقارنة البيانات بنجاح!" End Sub الملف
Test.xlsb

وعليكم السلام ورحمة الله وبركاته
نعم  اقصد كود فيجوال بيسك وهو موجود في الملف المرفق في ردي السايق 
اكتب في العمود A ارقام منصلة مثلا 1234567891234567 تتغير تلقائيا كل اربعة ارقام بينها فراغ
بالتوفيق
 

السيد  Khorsheed Omar
المعادلة
=IF([@[الاسم الثلاثي]]<>""; VLOOKUP([@[الاسم الثلاثي]]; 'البيانات الأساسية'!$A$2:$R$100;MATCH("2.2025"; 'البيانات الأساسية'!$1:$1; 0); FALSE); "") 1رواتب.xlsm

وعليكم السلام ورحمة الله وبركاته
الكود يعمل تلقائيا عند الانتهاء من الكتابة في خلية والخروج منها
New Microsoft Excel Worksheet (2).xlsb
 

وعليكم السلام ورحمة الله وبركاته 
الكود
Sub CreateBackup() Dim wb As Workbook Dim folderPath As String Dim fileName As String Dim fileExtension As String Dim backupName As String Dim backupNumber As Integer Dim fso As Object Dim file As Object Set wb = ThisWorkbook folderPath = wb.Path & "\" fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1) fileExtension = Mid(wb.Name, InStrRev(wb.Name, ".")) Set fso = CreateObject("Scripting.FileSystemObject") backupNumber = 0 For Each file In fso.GetFolder(folderPath).Files If InStr(file.Name, fileName) = 1 And InStr(file.Name, fileExtension) > 0 Then Dim currentNumber As Integer On Error Resume Next currentNumber = CInt(Mid(file.Name, Len(fileName) + 1, InStrRev(file.Name, fileExtension) - Len(fileName) - 1)) On Error GoTo 0 If currentNumber > backupNumber Then backupNumber = currentNumber End If End If Next file backupName = folderPath & fileName & (backupNumber + 1) & fileExtension wb.SaveCopyAs backupName MsgBox "تم إنشاء نسخة احتياطية باسم: " & vbCrLf & backupName, vbInformation, "نسخة احتياطية" End Sub الملف
Ehab.xlsb

تم التعديل
مكان التعديل 
        Case vbKeyEscape ' زر Esc
لم اقم بحذفها وانما قمت بتعليق او تجميد مهمتها باظافة فاصلة 
       ' Case vbKeyEscape ' زر Esc
يمكن حذف القاصلة المظاقة لتفعيلها
مقاطعة.xls
 

السلام عليكم 
تفضل الملف اتمنى ان يكون فيه طلبك 
الكود 
Private Sub ListBox1_Change() Dim selectedCount As Integer Dim i As Long selectedCount = 0 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then selectedCount = selectedCount + 1 End If Next i Label8.Caption = "عدد الصفوف المحددة: " & selectedCount End Sub بالتوفيق
الملف
ListBox - SelectCount.xlsm

السلام عليكم 
بعد اذن استالذنا أبومروان حل بواسطة المصقوفات
الكود
Sub ذكرين_انثيين() Dim ws As Worksheet Dim lastRow As Long Dim dataArray As Variant Dim males() As Variant Dim females() As Variant Dim resultArray() As Variant Dim maleCount As Long, femaleCount As Long Dim rowIndex As Long, i As Long, j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row dataArray = ws.Range("A2:F" & lastRow).Value ReDim males(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) ReDim females(1 To UBound(dataArray, 1), 1 To UBound(dataArray, 2)) maleCount = 0 femaleCount = 0 For i = 1 To UBound(dataArray, 1) If dataArray(i, 6) = "ذكر" Then maleCount = maleCount + 1 For j = 1 To UBound(dataArray, 2) males(maleCount, j) = dataArray(i, j) Next j ElseIf dataArray(i, 6) = "انثى" Then femaleCount = femaleCount + 1 For j = 1 To UBound(dataArray, 2) females(femaleCount, j) = dataArray(i, j) Next j End If Next i ReDim resultArray(1 To maleCount + femaleCount, 1 To UBound(dataArray, 2)) rowIndex = 1 i = 1 j = 1 Do While i <= maleCount Or j <= femaleCount For k = 1 To 2 If i <= maleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = males(i, col) Next col rowIndex = rowIndex + 1 i = i + 1 End If Next k For k = 1 To 2 If j <= femaleCount Then For col = 1 To UBound(dataArray, 2) resultArray(rowIndex, col) = females(j, col) Next col rowIndex = rowIndex + 1 j = j + 1 End If Next k Loop For i = 1 To UBound(resultArray, 1) resultArray(i, 1) = i ' الترقيم يبدأ من 1 Next i ws.Range("A2:F" & lastRow).ClearContents ws.Range("A2").Resize(UBound(resultArray, 1), UBound(resultArray, 2)).Value = resultArray MsgBox "تم الترتيب بنجاح !", vbInformation End Sub الملف 
فرز حسب الجنس بشروط.xlsb

السلام عليكم
الملف حجمه يتجاوز 11 مبقا بسبب التنسيق الشرطى للصفوف التسعة للعمود g من بداية العمود الى اخر العمود يعنى 9مليون خلية بها تنسيق شرطى
ارجو تحديد المطلوب للملف كما اخبرك استاذنا الفاضل حسونة حسبن
ساساهم  بخاصية البحث عن طالب واظافة حالة الطالب من السداد وعدم السداد واحضار اجمالى الرسوم الى صفحة main
وان هناك شئ نريد تعديله في الملف ارجو تحديده 
 
ملف المدرسة كامل الفصول 2024-2023.zip