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

وعليكم السلام ورحمة الله وبركاته
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

وعليكم السلام ورحمة الله وبركاته
كود ترحيل التغيير من الوصل الى السجل.xlsm

لم انتبه لذلك فعذرا 
شكرا لدعائك واطرائك  
الملف
 
بحث بجزء من الإسم (1).xlsb

السلام عليكم
 جربت  الكود  أحمد -إبراهيم  -إسلام -آية- أيمن - الادارية-الإدارية - ادارة   سميرة -شئ - وغيرهاكلها يالهمز وبدون همز  شغال 100%
الكود بقوم بالتغاضى عن :
جمبع  حروف الالف لاي كلمة بالقتح او بالكسر يتم البحث عنها سواء كتبتها بالهمز او بدونه
جمبع حروف الياء لاي كلمة عند البحث لو كتبنها الف مقصورة   ى   يتم احضار قيمتها
كذلك كلمة  شئ مثلا او ما في حكمها عند البحث لو كتبنها شى  بدون همزة يتم احضار قيمتها
كذلك اي كلمة فيها ة عند البحث لوكتبتها ه يتم احضار قيمتها
وسواء كان الحروف السابقة كانت في اي موقع من الكلمة في بداية او وسط او نهاية الكلمة  يقوم باحضار قيمتها
كذلك اذا كانت الكلمة حروفها لا تتكرر مع كلمة اخرى مثلا كلمة إبراهيم  لو كتبت في البحث هيم يحضر قيمتها
كذلك الكود مرن يمكن اظافة اي حروف للكود تريد اهمالها عند البحث
    str = Replace(str, "أ", "ا")
    str = Replace(str, "إ", "ا")
    str = Replace(str, "آ", "ا")
    str = Replace(str, "ي", "ى")
    str = Replace(str, "ئ", "ي")
    str = Replace(str, "ة", "ه")
ارفق لك الملف مرة اخرى ولم اغير شيئا بالكود
اصدار الاوفيس لدي 2016 وحسب علمى الكود متوافق مع كل الاصدرات
بحث حتى لو فى اخلاتف بسيط1.xls
 
 
 

وعليكم السلام ورحمة الله وبركاته
 حسب المعادلة في ملفك يمكن استبدالها بمعادلة اخرى لها نفس المهام
=SUMPRODUCT(C4:AA4; C$3:AA$3) طبعا لا يمكن لصقها مكان معادلة الصفيف الا بطريقة تظلبل معادلات الصفيف في العمود بالكامل ثم مسح البيانات  تم لصق المعادلة
الملف
المصنف1.xlsx
 

https://excelnoob.com/vba-password-remover/

نفضل كود الطباعة
سرى الشهادة الاعدادية (2).xlsb

وعليكم السلام ورحمة الله وبركاته
بدون ارفاق ملف ندخل  في باب الاحتمالات اما .... واما
الرسالة المعروضة تعني أن هناك عنصرًا (مثل ActiveX أو مكون في UserForm كـ ListBox أو ComboBox او غيره) في النموذج الخاص بك  اوفي الاكواد غير متوفر على جهازك. 
بمكنك معرفة الكائن او المكتبة الغير متوفرة من خلال :-
1- الكود 
2- او الانتقال إلى Developer > Visual Basic > Tools > References    
اذا وجدت كلمة MISSING  (بمعنى مفقود)  المكتوب امام الكلمة هي المكتبة المفقودة  الصورة المرفقة كمثال لمكتبة مفقودة
3- الغاء التاشير من كلمة  MISSING  قد يحل المشكلة احيانا وليس دائما
اتمنى ان اكون قدمت  لك ما يقيد
لك وافر التقدير والاحترام

 

وعليكم السلام ورحمة الله وبركاته
المعادلة 
=SUMIFS(C:C; B:B; ">=" & DATE($E$4;1;1); B:B; "<=" & DATE($E$4;12;31)) الملف
جمع القيم بناء على السنة.xlsx
 
وفقكم الله

السلام عليكم ورحمة الله وبركاته 
جرب المعادلة
=IF(AND(B2=0; A2>0); A2 + 1; IF(AND(B2>=1; A2=0); 0; IF(AND(B2>=1; A2>0); A2 - B2; A2))) الملف
المصنف1.xlsx

جربى الملف المرفق  وفيه حالة نفس المرتب
المعايير التى بنى عليها الكود هي :-
 
المقارنة بين المرتبات:
يقوم الكود بمقارنة المرتب الرسمي لكل موظف بين الملفين، ويضيف النتيجة إلى العمود H في ملف المقارنة:
زيادة في المرتب: إذا كان المرتب في الملف الثاني أكبر من المرتب في الملف الأول.
نقص في المرتب: إذا كان المرتب في الملف الثاني أقل من المرتب في الملف الأول.
نفس المرتب: إذا كان المرتب في الملفين متساويًا.
محذوف: إذا كان اسم الموظف موجود في الملف الأول ولكن غير موجود في الملف الثاني.
جديد: إذا كان اسم الموظف موجود في الملف الثاني ولكن غير موجود في الملف الأول.
نتائج المقارنة.xlsb
وهذا الملف خاص بمن زادت او نقصت او حذفو او جددفقط  بدون نفس المرتب 
نتائج المقارنة1.xlsb