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

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

وعليكم السلام ورحمة الله وبركاته للمرة الثالتة ادخل الموضوع واحمل الملف لكي احاول تقديم حل لطلبك اجدنى انرك طلبك واذهب الى موضوع اخر والسبب لا يوجد اي تواريخ بملفك وهو طلبك الاساسي عندما يكون ملفك جاهزا تجد الكثير من اعضاء المنتدى ينظرون الى طلبك ان شاء الله لك وافر التقدير والاحترام

السلام عليكم Book2.xlsm اعتقد ان الكود ضروري لعلاج الامر حسب علمى وبكون تلقائى عند تعديل اي خلية يعيد وضع الاشارة السالبة الى وضعها المطلوب يمكن تعديل النطاق من كود حدث الورق وكود المصنف ريما احد الاعضاء لديه حل بدون اكواد او معادلات Book2.xlsm

تم التعديل في المشاركة السايقة حمل الملف من جديد ولكن العدد 29 طالب حسب طلب صاحب الطلب عادل جلال وبمكن تعديلها من الكود لاي رقم تشاء

وعليكم السلام ورحمة الله وبركاته للمرة الرابعة ادخل على موضوعك وطليك وعند عدم وجود ملف اتركه وانتقل الى غيره الصورة لا توضح ما هي خصائص الخلايا وتنسيقها وهل عند كتابة الرقم مع العلامة السالبة توجد فراغات ام لا على كل حال ارفاق ملف كمثال تجعل مشاركة الاعضاء اكثر وتسهل لنا معرفة الخلل هذا ما اراه والله اعلم

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

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

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

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

وعليكم السلام ورحمة الله وبركانه ارفق ملف حتى يتضح طلبك

نعم بهذه الاظافة بمكن فهم طلبك الاستاذ محمد هشام اجاب عن طلبك بالمعادلات جزاه الله كل خير وان كنت تفضل الاكواد فاليك المرفق الملف احصاء عدد الطلبيات.xls ملاحظة اذا كان اصدار الاكسل عندك 2003 يجب التأكد من إضافة مرجع إلى مكتبة تشغيل نصوص Windows (Windows Script Host Object Model). يمكنك القيام بذلك من خلال الذهاب إلى Tools > References في محرر VBA وتحديد "Windows Script Host Object Model

السلام عليكم بعد اذن استالذنا أبومروان حل بواسطة المصقوفات الكود 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

السلام عليكم هل فتح الملف الثاني لم تخبرنى بالنتيجة يمكنك نسخ الكود ووضعه في حدث الورقة كلما كتبت رقما في العمود E يقوم بمسحه من العمود A ويتم نقل البيانات الى اعلى في العمود A لكي لا يبقى فراغ انتظر ردك

لا اعلم ما السبب حملت الملف ويعمل سارقع الملف مرة اخرى اخبرني بالنتيجة ازالة1.xlsm

وعليكم السلام ورحمة الله وبركاته في نفس الصفحة في العمود E بمكن تغييره من الكود الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range Dim foundCell As Range Dim ws As Worksheet Dim rng As Range Dim lastRow As Long Dim deleteRow As Long Set ws = Me Set rng = ws.Range("A:A") If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then Application.EnableEvents = False For Each cell In Intersect(Target, Me.Range("E:E")) If cell.Value <> "" Then Set foundCell = rng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not foundCell Is Nothing Then deleteRow = foundCell.Row foundCell.Delete xlShiftUp Else MsgBox "رقم العميل " & cell.Value & " غير موجود في قائمةالعملاء .", vbExclamation, "رقم غير موجود" End If End If Next cell lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rng = ws.Range("A2:A" & lastRow) rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo Application.EnableEvents = True End If End Sub الملف officena.xlsb

السلام عليكم بالنسبة لي لم تصلنى فكرة طلبك بعد في جدول التحليل مثلا اليوم الاول نوجد خانة Driver ID من يكون وهم كثر ارجو ملء اسطر من جدول التحليل حنى تصل الفكرة بوضوح تحباني

وعليكم السلام ورحمة الله وبركاته الاكسل يمكنه التعامل مع الأرقام التي تصل إلى 15 رقمًا وسيحول الأرقام المتبقية إلى أصفار عن طريق كود يمكن عمل طلبك بشرط تحويل النطاق المراد الكتابة فيه الى نص شاهد المرفق ويمكنك تعديل النطاق من الكود format cell.xlsb

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

وان اردتها بالمعادلات =IFERROR( INDEX(المعلومات!C$3:L$6;MATCH(C2;المعلومات!A$3:A$6;1);MATCH(D2;المعلومات!C$2:L$2;0)); "غير متوفر" ) 1ضريبة.xlsb

السلام عليكم الكود Sub CalculateTax() Dim wsInfo As Worksheet Dim wsEmployees As Worksheet Dim lastRow As Long Dim i As Long Dim j As Integer Dim salary As Double Dim status As String Dim tax As Double Dim minSalary As Double Dim maxSalary As Double Dim found As Boolean Set wsInfo = ThisWorkbook.Sheets("المعلومات") Set wsEmployees = ThisWorkbook.Sheets("الموظفين") lastRow = wsEmployees.Cells(wsEmployees.Rows.Count, 2).End(xlUp).Row For i = 2 To lastRow salary = wsEmployees.Cells(i, 3).Value status = wsEmployees.Cells(i, 4).Value found = False For j = 3 To 6 minSalary = wsInfo.Cells(j, 1).Value maxSalary = wsInfo.Cells(j, 2).Value If salary >= minSalary And salary <= maxSalary Then For Each cell In wsInfo.Range("C2:L2") If cell.Value = status Then tax = wsInfo.Cells(j, cell.Column).Value wsEmployees.Cells(i, 5).Value = tax found = True Exit For End If Next cell If found Then Exit For End If Next j If Not found Then wsEmployees.Cells(i, 5).Value = "" End If Next i MsgBox "تم حساب الضريبة بنجاح!", vbInformation End Sub الملف ضريبة.xlsb

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

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

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