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

السلام عليكم
قم بتفعيل الماكرو
الكود
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$G$2" Then Dim wsReport As Worksheet Dim wsSearch As Worksheet Dim lastRow As Long Dim i As Long Dim searchDate As Date Set wsReport = ThisWorkbook.Sheets("REPORT") Set wsSearch = ThisWorkbook.Sheets("Search2") searchDate = wsSearch.Range("G2").Value wsSearch.Range("B4:G1000").ClearContents lastRow = wsReport.Cells(wsReport.Rows.Count, "D").End(xlUp).Row Dim rowIndex As Long rowIndex = 4 For i = 2 To lastRow If wsReport.Cells(i, "D").Value = searchDate Then wsSearch.Cells(rowIndex, "B").Value = rowIndex - 3 wsSearch.Cells(rowIndex, "C").Value = wsReport.Cells(i, "G").Value wsSearch.Cells(rowIndex, "F").Value = wsReport.Cells(i, "J").Value wsSearch.Cells(rowIndex, "D").Value = wsReport.Cells(i, "I").Value wsSearch.Cells(rowIndex, "E").Value = wsReport.Cells(i, "H").Value rowIndex = rowIndex + 1 End If Next i End If End Sub New Microsoft Excel Worksheet (1).xlsb

السلام عليكم 
الحمد لله تم اصلاح العطل بالمنتدى
 
بواسطة  فلترة البيانات بالعمود الاول A يمكن تعديل حسب العمود الذي به بيانات في الجزء 
Field:=1 الكود 
 
Sub SaveRangeAsPDF() Dim ws As Worksheet Dim savePath As String Set ws = ThisWorkbook.Sheets("ورقة1") With ws .Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "D:\" & .Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" .Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False .AutoFilterMode = False End With MsgBox "تم حفظ الملف بنجاح!", vbInformation, "حفظ PDF" End Sub الملف 
DFP2.xlsb

السلام عليكم
دالة countif مضافاً إليها دالة max  ضعها في a2 ثم اسحبها للاسفل
=IF(COUNTIF($B$2:B2; B2)=1; MAX($A$1:A1)+1; "") ملف
ترقيم بتجاوز المكرر.xlsx

وعليكم السلام ورحمة الله وبركاته
="D:\الهويات\Pictures\" & ROW(A1) & ".jpg" ثم لسحب للاسفل
ويمكنك نسخها ولصقها كقيم يعد ذلك
New Microsoft Excel Worksheet.xlsx

السلام عليكم  
 بعض الاقسام غير موجودة  يمكنك اظافتها وسحب المعادلة اليها
تقرير.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