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

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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك إختيار ما يناسبك Sub CopyRowsmaktab() Dim LR As Long, I As Long, X As Long LR = Sheets("Main").Cells(Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Sheets("دريم").Range("B6:G" & Sheets("دريم").Rows.Count).ClearContents For I = 6 To LR If Sheets("Main").Cells(I, "B").Value = "دريم" Then Sheets("دريم").Range("B" & X & ":G" & X).Value = Sheets("Main").Range("B" & I & ":G" & I).Value X = X + 1 End If Next I Application.ScreenUpdating = True End Sub او Sub CopyRowsToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim WSRng As Range, destRng As Range, Criteria As String Set WS = Sheets("Main") Set dest = Sheets("دريم") Criteria = "دريم" LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = Criteria Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub او Sub CopiesToDream() Dim WS As Worksheet, dest As Worksheet Dim LastRow As Long, n As Long, X As Long Dim Ky As Boolean, WSRng As Range, destRng As Range Set WS = Sheets("Main") Set dest = Sheets("دريم") LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row X = 6 Ky = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Ky = True Exit For End If Next n If Not Ky Then MsgBox "لا يوجد بيانات مطابقة للنسخ", vbExclamation Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Exit Sub End If dest.Range("B6:G" & dest.Rows.Count).ClearContents For n = 6 To LastRow If WS.Cells(n, "B").Value = "دريم" Then Set WSRng = WS.Range(WS.Cells(n, "B"), WS.Cells(n, "G")) Set destRng = dest.Range(dest.Cells(X, "B"), dest.Cells(X, "G")) destRng.Value = WSRng.Value X = X + 1 End If Next n Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim srcWS As Worksheet, début As Long, Fin As Long Dim a As Variant, b As Variant, i As Long Set srcWS = Me a = srcWS.[B3].Value b = srcWS.[C3].Value If Not Intersect(Target, srcWS.Range("B3:C3")) Is Nothing Then If a = "" Or b = "" Then Exit Sub If IsNumeric(a) And IsNumeric(b) Then début = a Fin = b If début <= Fin Then srcWS.Range("F7:F" & srcWS.Rows.Count).ClearContents For i = début To Fin srcWS.Cells(6 + i - début + 1, "F").Value = i Next i Else MsgBox _ " بداية الترقيم يجب أن تكون أصغر أو تساوي نهاية الترقيم", vbExclamation, "خطأ في الإدخال" End If End If End If End Sub بالمعادلات =IF(ROW(F7)-ROW($F$7)+$B$3<=$C$3, ROW(F7)-ROW($F$7)+$B$3, "") ترقيم.xlsb

رحمك الله استاذ نادر وأسكنك الله فسيح جناته اللهم آمين

بارك الله فيك

شكرا استاذ عبد الله

تفضل استاذ @سامر محمود المرفق بعد التعديل . ووافني بالرد . serching-1.rar

تمام جزاكم الله خير الجزاء استاذنا عبدالله بشير

Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant, i As Long Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Or _ WS.Range("K2").Value > WS.Range("O2").Value Then MsgBox "يرجى التأكد من صحة التواريخ " & vbCrLf & _ "وتاريخ البدء لا يكون أكبر من تاريخ الانتهاء", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value ' لاخر اسم في عمود b Dim LastRow As Long LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row 'لاخر الكشف الصف 45 ' LastRow = 45 Application.ScreenUpdating = False WS.Range("D4:AH5").ClearContents With WS.Range("D4:AH45") .Interior.Pattern = xlNone .Font.Color = RGB(0, 0, 0) End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Range(WS.Cells(4, tmp), WS.Cells(LastRow, tmp)).Interior.Color = RGB(255, 255, 0) WS.Range(WS.Cells(4, tmp), WS.Cells(5, tmp)).Font.Color = RGB(255, 0, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub جدول الحصص الإضافية 2.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

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

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

اخي الكود يشتغل معي بدون مشاكل كما في الصورة المرفقة على العموم تم تعديل الكود في المشاركة السابقة مع تعديل بسيط للكود الأول يمكنك تجربتهم وإختيار ما يناسبك Book2 v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim dictA As Object, dictB As Object, dictC As Object, dictD As Object Dim n As Variant, a As Variant, b As Variant, c As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If WorksheetFunction.CountA(.Range("A2:A" & Irow)) = 0 And _ WorksheetFunction.CountA(.Range("B2:B" & Irow)) = 0 Then MsgBox "لا توجد بيانات للمقارنة", vbExclamation Exit Sub End If 'Code ............. .................. Set dictC = CreateObject("Scripting.Dictionary") Set dictD = CreateObject("Scripting.Dictionary") For i = 2 To Irow If WS.Cells(i, 3).Value <> "" Then dictC(WS.Cells(i, 3).Value) = True If WS.Cells(i, 4).Value <> "" Then dictD(WS.Cells(i, 4).Value) = True Next i For i = 2 To Irow If WS.Cells(i, 1).Value <> "" Then If dictC.exists(WS.Cells(i, 1).Value) Or dictD.exists(WS.Cells(i, 1).Value) Then WS.Cells(i, 1).Interior.Color = RGB(255, 255, 0) End If End If If WS.Cells(i, 2).Value <> "" Then If dictC.exists(WS.Cells(i, 2).Value) Or dictD.exists(WS.Cells(i, 2).Value) Then WS.Cells(i, 2).Interior.Color = RGB(255, 165, 0) End If End If Next i Application.ScreenUpdating = True End Sub مقارنة 3.xlsb

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx