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

السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM تم تعديل الكود حسب طلبك ليعرض عمودين في ListBox داخل نموذج البحث مثلا (الإسم + التسلسل) يمكنك تعديله بما يناسبك وقد قمت بمحاولة تنقيحه وتحسينه ليكون أكثر كفاءة وتنظيما يرجى أولا تفريغ جميع الأكواد السابقة من النموذج ثم نسخ الكود التالي بالكامل Option Explicit Private ColArr As Variant Public Property Get WS() As Worksheet: Set WS = Sheets("add"): End Property Public Property Get dest() As Worksheet: Set dest = Sheets("search"): End Property Private Sub UserForm_Initialize() TextBox1.SetFocus 'قم بتحديد الأعمدة المرغوب عرضها ColArr = Array(2, 1) ' 2 = الإسم / 1 = التسلسل With ListBox1: .ColumnCount = UBound(ColArr) + 1: .ColumnWidths = "100pt;40pt": End With End Sub Private Sub TextBox1_Change() Dim c As Range, tmp As String, lastRow As Long, i As Long, listCount As Long ListBox1.Clear If IsEmpty(ColArr) Then Exit Sub tmp = Trim(TextBox1.Value) If Len(tmp) = 0 Then Exit Sub SetApp False lastRow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row For Each c In WS.Range(WS.Cells(5, ColArr(0)), WS.Cells(lastRow, ColArr(0))) If InStr(1, c.Value, tmp, vbTextCompare) > 0 Then ListBox1.AddItem c.Value listCount = ListBox1.listCount For i = 1 To UBound(ColArr) ListBox1.List(listCount - 1, i) = c.EntireRow.Cells(1, ColArr(i)).Value Next i End If Next c SetApp True End Sub Private Sub CommandButton1_Click() Dim Irow As Long, f As Long, i As Long, xName As String, cnt As Boolean: cnt = False If ListBox1.listCount = 0 Then MsgBox "لا توجد نتائج للبحث", vbExclamation, "تنبيه": Exit Sub xName = Trim(TextBox1.Value): Irow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row SetApp False For i = 5 To Irow If WS.Cells(i, ColArr(0)).Value = xName Then If Not cnt Then dest.Range("A8:L" & dest.Rows.Count).ClearContents f = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 dest.Range("A" & f).Resize(1, 12).Value = WS.Cells(i, 2).Resize(1, 12).Value cnt = True End If Next i If Not cnt Then MsgBox "لم يتم العثور على الاسم" & xName & " ضمن كشف المرحليات", vbInformation, "نتيجة البحث" SetApp True: Unload Me End Sub Private Sub ListBox1_Click() TextBox1.Value = ListBox1.List(ListBox1.ListIndex, 0) End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub المرحليات أوفيسنا v2.xlsm

وعليكم السلام ورحمة الله وبركانه لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت اليك التعديل Private Sub TextBox1_Change() ListBox1.Clear Application.ScreenUpdating = False Dim ws As Worksheet: Set ws = Sheets("add") Dim lr As Long, c As Range, b As Integer, k As Long Dim arrData() As Variant Dim i As Long, j As Long lr = 0 For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) b = InStr(1, c.Value, TextBox1.Value, vbTextCompare) If b > 0 Then lr = lr + 1 ReDim Preserve arrData(1 To 2, 1 To lr) arrData(1, lr) = c.Value arrData(2, lr) = c.Offset(0, 4).Value End If Next c With ListBox1 .ColumnCount = 2 .ColumnWidths = "100;100" If lr > 0 Then .List = Application.Transpose(arrData) End If End With Application.ScreenUpdating = True End Sub في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم arrData(2, lr) = c.Offset(0, 4).Value كنا يمكنك من تعديل عرض العمود بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني .ColumnWidths = "100;100" ارجو ما قدمته ان يكون طلبك كل عام وانت بخير المرحليات أوفيسنا.xlsm

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

المرجوا إرفاق الملف الذي يتضمن نفس البيانات والوظائف المذكورة للوقوف وراء سبب ظهور رسالة الخطأ معك

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي DurationToFullWords ، وهي تقوم بحساب الفارق بين تاريخين معينين (StartDate و EndDate) وتنسيق النتيجة بشكل نصي باستخدام الوحدات الزمنية مثل "سنة" ، "شهر" ، و "يوم" . كما تدعم العديد من الخيارات لتخصيص المخرجات مثل تحديد تنسيق النتيجة وإظهار الأرقام مع الكلمات العربية . 1️⃣ الجزء الأول تعريف المعاملات والتأكد من صحة البيانات المدخلة :- وقد تم تعديل الفكرة بحيث يستقبل الكود التاريخين الأصغر أولاً ثم الأكبر بغض النظر عن ما اذا كان مربع النص الأول يضم تاريخ أكبر أم أصغر .. If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If حيث StartDate و EndDate هما التاريخان اللذان يتم مقارنة الفارق بينهما . أولاً يتم التأكد من أن كلا التاريخين مدخلين بشكل صحيح (غير فارغين) . ثم يقارن اي القيمتين أسغر لجعلها بداية والأكبر نهاية 😁 . 2️⃣ الجزء الثاني حساب الفارق بين التواريخ :- y = DateDiff("yyyy", tempDate, EndDate) m = DateDiff("m", tempDate, EndDate) d = DateDiff("d", tempDate, EndDate) totalDays = DateDiff("d", StartDate, EndDate) حيث DateDiff هي دالة تستخدم لحساب الفرق بين التواريخ بوحدات مختلفة مثل السنوات (yyyy) ، الأشهر (m) ، و الأيام (d) . فيتم حساب الفرق بالسنوات أولاً ، ثم الأشهر ، وأخيراً الأيام . ثم يتم جمع totalDays لحساب الفارق الإجمالي بالأيام بين التاريخين . 3️⃣ الجزء الثالث المعالجة الخاصة للأشهر والأيام :- If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If حيث RoundResults هو خيار اختياري لتقريب النتائج . فإذا كان هذا الخيار مفعلًا ، يتم تعديل الأشهر أو الأيام ليتم تقريبها بشكل منطقي . فإذا كانت الأشهر 11 شهراً والأيام 25 أو أكثر ، يتم زيادة السنة بمقدار واحد . وإذا كانت الأشهر 5 والأيام 25 أو أكثر ، يتم تحويل الأشهر إلى 6 . 4️⃣ الجزء الرابع تنسيق النتائج حسب الخيارات :- Select Case FormatOption Case "Y" ' تنسيق الفرق بالسنوات فقط Case "M" ' تنسيق الفرق بالأشهر فقط Case "D" ' تنسيق الفرق بالأيام فقط Case "M/D" ' تنسيق الفرق بالأشهر والأيام Case "Y/M" ' تنسيق الفرق بالسنوات والأشهر Case Else ' تنسيق كامل (سنوات، أشهر، أيام) End Select التوضيح على شكل نقاط :- تعتمد الدالة على FormatOption لتحديد التنسيق الذي يجب أن تظهر به النتيجة ، كالتالي :- Y : يعرض النتيجة بالسنوات فقط . M : يعرض النتيجة بالأشهر فقط . D : يعرض النتيجة بالأيام فقط . M/D : يعرض النتيجة بالأشهر والأيام . Y/M : يعرض النتيجة بالسنوات والأشهر . القيمة الافتراضية : يعرض النتيجة كاملة (سنوات ، أشهر ، أيام) . 5️⃣ الجزء الخامس الدوال المساعدة :- Function SimpleUnit(Number As Long, UnitName As String) As String وتقوم هذه الدالة بـ :- بتنسيق الأرقام مع الوحدات الزمنية مثل "سنة" ، "شهر" ، أو "يوم" . تتعامل مع العدد بصيغة الجمع أو المفرد حسب الرقم المدخل . على سبيل المثال ، إذا كان العدد 1 ، يتم إرجاع "1 سنة" أو "1 شهر"، وإذا كان العدد 2 يتم إرجاع "سنتين" أو "شهرين" ... إلخ . Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String وتقوم هذه الدالة بتنسيق الأرقام مع الوحدات بشكل معين . على سبيل المثال :- OnlyNumbers : إذا كان True ، تعرض الأرقام فقط . ShowNumberWithWord : إذا كان True ، تعرض الرقم مع الكلمة باللغة العربية في قوسين مثل : "5 (خمسة) سنوات" . Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية . كما أنها تدعم الكلمة بصيغة المذكر أو المؤنث حسب القيمة المدخلة في IsFeminine . Function NumberWithUnitArabic(Number As Long, UnitName As String) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية مع الوحدة المناسبة (مثل "سنة واحدة" ، "شهران" ، "أيام") . 6️⃣ الجزء السادس التعامل مع الحروف العطف (مثل "و" ) .في الجزء :- If Right(result, 3) = " و " Then result = Left(result, Len(result) - 3) End If فبعد تنسيق النتيجة ، يتم إزالة الفاصلة الزائدة "و" في النهاية إذا كانت موجودة . 7️⃣ الجزء السابع : النتيجة النهائية :- If result = "" Then result = "أقل من يوم" DurationToFullWords = result في حال كانت النتيجة فارغة ( قيمة بفارق 0 ) ، يتم تعيين النتيجة إلى "أقل من يوم" . 💢 تم إضافة دالة تقوم بتفقيط التاريخ بأكثر من شكل ( 3 تنسيقات ) ، على سبيل المثال ، تاريخ اليوم هو 08/04/2025 والنتيجة له :- الثامن من شهر نيسان لعام ألفين وخمسة وعشرين م الثامن من شهر أبريل لعام ألفين وخمسة وعشرين م والجزء الجديد هو قراءة التاريخ بالأشهر الهجرية :- الثامن من شهر ربيع ثان لعام ألفين وخمسة وعشرين هـ 📛 الآن الكود العام في مديول منفرد :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit Function DurationToFullWords(StartDate As Variant, EndDate As Variant, _ Optional FormatOption As String = "", _ Optional ShortFormat As Boolean = False, _ Optional OnlyNumbers As Boolean = False, _ Optional ShowNumberWithWord As Boolean = False, _ Optional RoundResults As Boolean = False) As String If FormatOption = "" Then FormatOption = "FullWords" Dim y As Long, m As Long, d As Long Dim tempDate As Date Dim Result As String Dim totalMonths As Long Dim totalDays As Long Dim weeks As Long If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If tempDate = StartDate totalDays = DateDiff("d", StartDate, EndDate) y = DateDiff("yyyy", tempDate, EndDate) If DateAdd("yyyy", y, tempDate) > EndDate Then y = y - 1 tempDate = DateAdd("yyyy", y, tempDate) m = DateDiff("m", tempDate, EndDate) If DateAdd("m", m, tempDate) > EndDate Then m = m - 1 tempDate = DateAdd("m", m, tempDate) d = DateDiff("d", tempDate, EndDate) totalMonths = (y * 12) + m weeks = totalDays \ 7 If ShortFormat Then If y > 0 Then Result = Result & SimpleUnit(y, "سنة") & " و " If m > 0 Then Result = Result & SimpleUnit(m, "شهر") & " و " If d > 0 Then Result = Result & SimpleUnit(d, "يوم") & " و " Else If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If End If Select Case FormatOption Case "Y" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) Else If m < 6 Then Result = "أقل من نصف سنة" ElseIf m = 6 And d = 0 Then Result = "نصف سنة" ElseIf m = 6 And d > 0 Then Result = "أكثر من نصف سنة" ElseIf m > 6 Then Result = "أكثر من نصف سنة" End If End If Case "M" If totalMonths > 0 Then Result = FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) ElseIf d > 0 Then If d = 30 Or d = 31 Then Result = "شهر" ElseIf d < 30 Then Result = "أقل من شهر" End If Else Result = "أقل من شهر" End If Case "D" Result = FormatNumberWithWord(totalDays, "يوم", OnlyNumbers, ShowNumberWithWord) Case "M/D" If totalMonths > 0 Then Result = Result & FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) If d > 0 Then Result = Result & " و " End If If d > 0 Then If d >= 7 And totalMonths = 0 Then Select Case weeks Case 1 Result = Result & "أسبوع" Case 2 Result = Result & "أسبوعان" Case 3 To 4 Result = Result & FormatNumberWithWord(weeks, "أسبوع", OnlyNumbers, ShowNumberWithWord) Case Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End If End If Case "Y/M" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) Case Else If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) & " و " If d > 0 Then Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select End If If Right(Result, 3) = " و " Then Result = Left(Result, Len(Result) - 3) End If If Result = "" Then Result = "أقل من يوم" DurationToFullWords = Result End Function Function SimpleUnit(Number As Long, UnitName As String) As String Select Case Number Case 1 SimpleUnit = "1 " & UnitName Case 2 If UnitName = "سنة" Then SimpleUnit = "2 سنتين" ElseIf UnitName = "يوم" Then SimpleUnit = "2 يومين" Else SimpleUnit = "2 " & UnitName & "ين" End If Case 3 To 10 If UnitName = "سنة" Then SimpleUnit = Number & " سنوات" ElseIf UnitName = "شهر" Then SimpleUnit = Number & " أشهر" ElseIf UnitName = "يوم" Then SimpleUnit = Number & " أيام" Else SimpleUnit = Number & " " & UnitName End If Case Else SimpleUnit = Number & " " & UnitName End Select End Function Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String If OnlyNumbers Then FormatNumberWithWord = SimpleUnit(Number, UnitName) ElseIf ShowNumberWithWord Then FormatNumberWithWord = Number & " (" & NumberToArabicUnit(Number, UnitName) & ")" Else FormatNumberWithWord = NumberToArabicUnit(Number, UnitName) End If End Function Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String Dim UnitsMasc, UnitsFem, Tens, TeensMasc, TeensFem, Hundreds UnitsMasc = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") UnitsFem = Array("", "واحدة", "اثنتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع") TeensMasc = Array("عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") TeensFem = Array("عشر", "إحدى عشرة", "اثنتا عشرة", "ثلاث عشرة", "أربع عشرة", "خمس عشرة", "ست عشرة", "سبع عشرة", "ثماني عشرة", "تسع عشرة") Tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") Hundreds = Array("", "مئة", "مئتان", "ثلاثمئة", "أربعمئة", "خمسمئة", "ستمئة", "سبعمئة", "ثمانمئة", "تسعمئة") Dim Words As String Dim n As Long Dim h, t, u As Integer If Number = 0 Then NumberToArabicWords = "صفر" Exit Function End If If Number = 10 Then NumberToArabicWords = IIf(IsFeminine, "عشر", "عشرة") Exit Function End If If Number > 999 Then Dim Thousands As Long Thousands = Number \ 1000 Words = NumberToArabicWords(Thousands, False) & " ألف" n = Number Mod 1000 If n > 0 Then Words = Words & " و " & NumberToArabicWords(n, IsFeminine) NumberToArabicWords = Words Exit Function End If h = Number \ 100 t = (Number Mod 100) \ 10 u = Number Mod 10 If h > 0 Then Words = Hundreds(h) If (Number Mod 100) >= 11 And (Number Mod 100) <= 19 Then If Words <> "" Then Words = Words & " و " If IsFeminine Then Words = Words & TeensFem((Number Mod 100) - 10) Else Words = Words & TeensMasc((Number Mod 100) - 10) End If Else Dim UnitsArray UnitsArray = IIf(IsFeminine, UnitsFem, UnitsMasc) If t > 1 Then If u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) & " و " & Tens(t) Else If Words <> "" Then Words = Words & " و " Words = Words & Tens(t) End If ElseIf u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) End If End If NumberToArabicWords = Words End Function Function NumberWithUnitArabic(Number As Long, UnitName As String) As String Dim Result As String Select Case UnitName Case "سنة" Select Case Number Case 1: Result = "سنة واحدة" Case 2: Result = "سنتان" Case 3 To 10: Result = Number & " سنوات" Case Else: Result = Number & " سنة" End Select Case "شهر" Select Case Number Case 1: Result = "شهر واحد" Case 2: Result = "شهران" Case 3 To 10: Result = Number & " أشهر" Case Else: Result = Number & " شهر" End Select Case "يوم" Select Case Number Case 1: Result = "يوم واحد" Case 2: Result = "يومان" Case 3 To 10: Result = Number & " أيام" Case Else: Result = Number & " يوم" End Select Case Else Result = Number & " " & UnitName End Select NumberWithUnitArabic = Result End Function Function NumberToArabicUnit(Number As Long, UnitName As String) As String Dim word As String Dim feminine As Boolean Select Case UnitName Case "سنة": feminine = True Case "شهر": feminine = False Case "يوم": feminine = False End Select Select Case Number Case 1 word = UnitName & " " & IIf(feminine, "واحدة", "واحد") Case 2 If feminine Then word = "سنتان" Else If UnitName = "يوم" Then word = "يومان" Else word = UnitName & "ان" End If End If Case 3 To 10 word = NumberToArabicWords(Number, feminine) If UnitName = "يوم" Then word = word & " أيام" ElseIf UnitName = "سنة" Then word = word & " سنوات" ElseIf UnitName = "شهر" Then word = word & " أشهر" End If Case Else word = NumberToArabicWords(Number, feminine) & " " & UnitName End Select NumberToArabicUnit = word End Function Function ConvertDateToText(ByVal DateValue As Date, _ Optional ByVal CalendarType As String = "Gregorian", _ Optional ByVal MonthNameStyle As String = "Standard") As String Dim dayNumber As Integer Dim monthNumber As Integer Dim yearNumber As Integer Dim dayText As String Dim monthText As String Dim yearText As String If LCase(CalendarType) = "hijri" Then dayNumber = Val(Format$(DateValue, "dd", vbCalHijri)) monthNumber = Val(Format$(DateValue, "mm", vbCalHijri)) yearNumber = Val(Format$(DateValue, "yyyy", vbCalHijri)) Else dayNumber = day(DateValue) monthNumber = month(DateValue) yearNumber = year(DateValue) End If Select Case dayNumber Case 1: dayText = "الأول" Case 2: dayText = "الثاني" Case 3: dayText = "الثالث" Case 4: dayText = "الرابع" Case 5: dayText = "الخامس" Case 6: dayText = "السادس" Case 7: dayText = "السابع" Case 8: dayText = "الثامن" Case 9: dayText = "التاسع" Case 10: dayText = "العاشر" Case 11: dayText = "الحادي عشر" Case 12: dayText = "الثاني عشر" Case 13: dayText = "الثالث عشر" Case 14: dayText = "الرابع عشر" Case 15: dayText = "الخامس عشر" Case 16: dayText = "السادس عشر" Case 17: dayText = "السابع عشر" Case 18: dayText = "الثامن عشر" Case 19: dayText = "التاسع عشر" Case 20: dayText = "العشرين" Case 21: dayText = "الحادي والعشرين" Case 22: dayText = "الثاني والعشرين" Case 23: dayText = "الثالث والعشرين" Case 24: dayText = "الرابع والعشرين" Case 25: dayText = "الخامس والعشرين" Case 26: dayText = "السادس والعشرين" Case 27: dayText = "السابع والعشرين" Case 28: dayText = "الثامن والعشرين" Case 29: dayText = "التاسع والعشرين" Case 30: dayText = "الثلاثين" Case 31: dayText = "الحادي والثلاثين" Case Else: dayText = CStr(dayNumber) End Select If LCase(CalendarType) = "hijri" Then monthText = Choose(monthNumber, _ "محرم", "صفر", "ربيع أول", "ربيع ثان", "جمادى أول", "جمادى ثان", _ "رجب", "شعبان", "رمضان", "شوال", "ذو القعدة", "ذو الحجة") ElseIf LCase(MonthNameStyle) = "syriac" Then monthText = Choose(monthNumber, _ "كانون الثاني", "شباط", "آذار", "نيسان", "أيار", "حزيران", _ "تموز", "آب", "أيلول", "تشرين الأول", "تشرين الثاني", "كانون الأول") Else monthText = Choose(monthNumber, _ "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") End If yearText = NumberToArabicText(yearNumber) Dim eraSuffix As String If LCase(CalendarType) = "hijri" Then eraSuffix = " هـ" Else eraSuffix = " م" End If ConvertDateToText = dayText & " من شهر " & monthText & " لعام " & yearText & eraSuffix End Function Function NumberToArabicText(ByVal TheNumber As Long) As String Dim MyArray1(0 To 9) As String Dim MyArray2(0 To 9) As String Dim MyArray3(0 To 9) As String Dim Result As String Dim Hundreds As String Dim Tens As String Dim Ones As String Dim AndConnector As String AndConnector = " و" MyArray1(0) = "" MyArray1(1) = "مائة" MyArray1(2) = "مائتين" MyArray1(3) = "ثلاثمائة" MyArray1(4) = "أربعمائة" MyArray1(5) = "خمسمائة" MyArray1(6) = "ستمائة" MyArray1(7) = "سبعمائة" MyArray1(8) = "ثمانمائة" MyArray1(9) = "تسعمائة" MyArray2(0) = "" MyArray2(1) = " عشر" MyArray2(2) = "عشرين" MyArray2(3) = "ثلاثين" MyArray2(4) = "أربعين" MyArray2(5) = "خمسين" MyArray2(6) = "ستين" MyArray2(7) = "سبعين" MyArray2(8) = "ثمانين" MyArray2(9) = "تسعين" MyArray3(0) = "" MyArray3(1) = "واحد" MyArray3(2) = "اثنين" MyArray3(3) = "ثلاثة" MyArray3(4) = "أربعة" MyArray3(5) = "خمسة" MyArray3(6) = "ستة" MyArray3(7) = "سبعة" MyArray3(8) = "ثمانية" MyArray3(9) = "تسعة" If TheNumber = 0 Then NumberToArabicText = "صفر" Exit Function End If Dim HundredsDigit As Integer Dim TensDigit As Integer Dim OnesDigit As Integer HundredsDigit = (TheNumber Mod 1000) \ 100 TensDigit = (TheNumber Mod 100) \ 10 OnesDigit = TheNumber Mod 10 If HundredsDigit >= 0 And HundredsDigit <= 9 Then Hundreds = MyArray1(HundredsDigit) Else Hundreds = "" End If If TensDigit = 1 Then Select Case OnesDigit Case 0: Tens = "عشرة" Case 1: Tens = "إحدى عشرة" Case 2: Tens = "إثنتا عشرة" Case Else: Tens = MyArray3(OnesDigit) & MyArray2(TensDigit) End Select Else Ones = MyArray3(OnesDigit) Tens = MyArray2(TensDigit) If Ones <> "" And Tens <> "" Then Tens = Ones & AndConnector & Tens Else Tens = Ones & Tens End If End If If Hundreds <> "" And Tens <> "" Then Result = Hundreds & AndConnector & Tens Else Result = Hundreds & Tens End If If TheNumber > 999 Then Dim Thousands As Long Dim Remainder As Long Thousands = TheNumber \ 1000 Remainder = TheNumber Mod 1000 Dim ThousandsText As String ThousandsText = NumberToArabicText(Thousands) If Thousands = 1 Then ThousandsText = "ألف" ElseIf Thousands = 2 Then ThousandsText = "ألفين" ElseIf Thousands >= 3 And Thousands <= 10 Then ThousandsText = NumberToArabicText(Thousands) & " آلاف" Else ThousandsText = NumberToArabicText(Thousands) & " ألف" End If If Remainder > 0 Then Result = ThousandsText & AndConnector & NumberToArabicText(Remainder) Else Result = ThousandsText End If End If NumberToArabicText = Result End Function ولتسهيل فهم الموضوع عند الإستدعاءات المختلفة ، تم انشاء نموذج بسيط يضم 22 زر ولكل زر طريقة استدعاء مختلفة تسهيلاً للمستخدم كي تتوضح له آلية العمل . كما تم اضافة 3 مربعات نص كل منها يعرض التفقيط بشكل مختلف . ♻ المرفق :- Date Duration to Arabic Words.accdb

حياك الله اخوي الغالي لنفترض أن لدينا حقلًا في جدول باسم LinkName كما في مثالك ، ويحتوي على الرابط التشعبي التالي : "Visit Google#https://www.google.com#Homepage" نتيجة HyperlinkPart([LinkName], 1) : "Visit Google" (النص الظاهر) . نتيجة HyperlinkPart([LinkName], 2) : "Homepage" (العنوان الفرعي) . نتيجة HyperlinkPart([LinkName], 3) : "https://www.google.com" (الرابط الأساسي) . متى نستخدم كلاً منهما ؟ استخدم 1 عندما تريد عرض النص الذي يراه المستخدم فقط (حسب مثالك طبعاً ) استخدم 2 عند الحاجة إلى استخراج إشارة مرجعية أو موقع داخل ملف ( مثل اكسل أو وورد ) استخدم 3 لاستخراج الرابط الفعلي ( URL أو مسار الملف ) فاستخدمت 1 لما يتوافق مع مثالك الذي طرحته ، ولكن جرب الحالة 3 😉 .

بارك الله فيك ونفع بك

هل تبحثون عن طريقة مرنة وقوية للتحكم في فتح وإغلاق النماذج في قواعد البيانات ؟ إليكم دالة NavigateForm الحل الأمثل لتبسيط إدارة فتح وإغلاق النماذج أو التبديل بين الفتح/والإغلاق بكفاءة عالية! ما هي دالة NavigateForm ؟ NavigateForm هي دالة تستخدم في وحدة نمطية عامة (Module) لإدارة النماذج بطريقة احترافية تقوم الدالة بـالآتي : إغلاق النموذج الحالي أو نموذج محدد فتح نموذج آخر بوضع عرض محدد (مثل العرض العادي - الحوار - التصميم - المخفي - . . . .. إلخ) التبديل بإغلاق نموذج وفتح أخر أو فتح نموذج أخر مع الابقاء على النموذج الأب مفتوح تطبيق فلاتر عبر WhereCondition لتحديد السجلات المعروضة تمرير بيانات إضافية عبر OpenArgs لتخصيص سلوك النموذج الدالة مثالية للمطورين اللي عايزين تنقل سلس بين النماذج مع تحكم دقيق في أوضاع الفتح والإغلاق سواء في تطبيقات بسيطة أو معقدة مميزات دالة NavigateForm مرونة عالية: تدعم إغلاق النموذج الحالي أو إغلاق نموذج محدد أو فتح نموذج بوضع معين أو الجمع بين العمليات دي في استدعاء واحد تعداد مخصص (FormOpenMode): يشمل كل أوضاع فتح النماذج الشائعة: - DefaultMode: الوضع الافتراضي - NormalMode: العرض العادي (Form View) - DesignMode: وضع التصميم (Design View) - DatasheetMode: عرض ورقة البيانات (Datasheet View) - PreviewMode: معاينة الطباعة (Print Preview) - LayoutMode: عرض التخطيط (Layout View) - AddMode: إضافة سجل جديد - EditMode: تعديل السجلات - ReadOnlyMode: القراءة فقط - HiddenMode: فتح النموذج في الوضع المخفي - DialogMode: فتح النموذج كحوار (يوقف تنفيذ الكود حتى الإغلاق) معالجة الأخطاء: تتضمن معالجة أخطاء مدمجة للتعامل مع حالات زي: - أسماء نماذج غير موجودة - محاولة إغلاق نموذج غير مفتوح - أخطاء تشغيل غير متوقعة التعامل مع الإغلاق اليدوي: الدالة بتتعامل بذكاء مع إغلاق النماذج يدويًا (مثل ضغط "X" في النافذة) وبتضمن إمكانية إعادة فتح النموذج بدون مشاكل منع الاستدعاءات المتكررة: بتمنع فتح النموذج مرتين بنفس المعاملات لو كان مفتوح بالفعل، مع إعادة تعيين السجل بعد كل عملية توثيق احترافي: الكود مرفق بتوثيق مفصل يشرح المعاملات و الأوضاع و وأمثلة الاستدعاء سهولة التكامل: يمكن استدعاؤها من أحداث النماذج (مثل أزرار OnClick) أو ماكرو أو كود VBA آخر دعم الفلاتر والبيانات الإضافية: بتسمح بتطبيق فلاتر عبر WhereCondition وتمرير بيانات مخصصة عبر OpenArgs الكود الكود متاح في وحدة نمطية عامة (basNavigateForm)، ويتضمن: تعداد FormOpenMode لتحديد أوضاع الفتح دالة IsFormPresent للتحقق من وجود النموذج دالة NavigateForm لإدارة فتح وإغلاق النماذج Option Compare Database Option Explicit ' متغير عام للتحكم في طباعة رسائل التصحيح Public DebugPrintEnabled As Boolean ' تعداد لتحديد أوضاع فتح النموذج Public Enum FormOpenMode DefaultMode = 0 ' الوضع الافتراضي (يفتح النموذج بإعدادات Access الافتراضية) NormalMode = 1 ' العرض العادي (Form View) DesignMode = 2 ' وضع التصميم (Design View) DatasheetMode = 3 ' عرض ورقة البيانات (Datasheet View) PreviewMode = 4 ' عرض معاينة الطباعة (Print Preview) LayoutMode = 5 ' عرض التخطيط (Layout View) AddMode = 6 ' وضع إضافة سجل جديد EditMode = 7 ' وضع تعديل السجلات ReadOnlyMode = 8 ' وضع القراءة فقط HiddenMode = 9 ' الوضع المخفي (Hidden) DialogMode = 10 ' وضع الحوار (Dialog) End Enum ' ======================================================================= ' الدالة: التحقق من وجود نموذج في قاعدة البيانات ' الوصف: ترجع True إذا كان النموذج موجودًا في قاعدة البيانات، وFalse إذا لم يكن موجودًا ' المعاملات: formName (String) - اسم النموذج المراد التحقق منه ' ' المؤلف: [ابو جودي - منتديات أوفيسنا] ' تاريخ الإنشاء: 24 مايو 2025 ' الإصدار: 2.1 ' ======================================================================= Public Function IsFormPresent(formName As String) As Boolean On Error Resume Next Dim formObj As Object Set formObj = CurrentProject.AllForms(formName) IsFormPresent = Not (formObj Is Nothing) ' طباعة نتيجة التحقق إذا كانت الطباعة مفعلة If DebugPrintEnabled Then Debug.Print "IsFormPresent: التحقق من النموذج '" & formName & "': " & IsFormPresent End If Set formObj = Nothing On Error GoTo 0 End Function ' ======================================================================= ' NavigateForm ' ' وصف: ' دالة عامة للتحكم في فتح وإغلاق نماذج Microsoft Access. تتيح إغلاق ' النموذج الحالي أو نموذج محدد، وفتح نموذج آخر بوضع محدد مع إمكانية ' تمرير بيانات إضافية عبر OpenArgs وتطبيق فلتر عبر WhereCondition. ' إذا كان النموذج المراد فتحه مفتوحًا بالفعل، يتم إغلاقه وإعادة فتحه ' بالوضع المحدد مع الحفاظ على OpenArgs وWhereCondition. ' ' المعاملات: ' - formToClose (اختياري، String): اسم النموذج المراد إغلاقه. ' - formToOpen (اختياري، String): اسم النموذج المراد فتحه. ' - openMode (اختياري، FormOpenMode): وضع فتح النموذج. ' - openArgs (اختياري، Variant): بيانات إضافية لتمريرها إلى النموذج المفتوح. ' - WhereCondition (اختياري، String): شرط فلترة لتحديد السجلات المعروضة. ' ' القيمة المرجعة: ' - Boolean: True إذا نجحت العملية، False إذا حدث خطأ. ' ' أمثلة: ' Call NavigateForm ' إغلاق النموذج الحالي ' Call NavigateForm("Form1") ' إغلاق Form1 ' Call NavigateForm("", "Form2", DialogMode) ' فتح Form2 كحوار ' Call NavigateForm("Form1", "Form2", AddMode) ' إغلاق Form1 وفتح Form2 لإضافة سجل ' Call NavigateForm("", "Form2", NormalMode, "CustomerID=123", "ID=123") ' فتح Form2 مع فلتر ' Call NavigateForm("Form1", "Form2", DialogMode, "Source=MainForm") ' إغلاق Form1 وفتح Form2 كحوار ' Call NavigateForm("", "Form1", DialogMode, , "ID=456") ' إغلاق Form1 وإعادة فتحه كحوار مع فلتر ' ' ملاحظات: ' - تأكد من وجود النماذج المحددة في قاعدة البيانات. ' - وضع DialogMode يوقف تنفيذ الكود حتى إغلاق النموذج. ' - وضع DesignMode قد يكون مقيدًا في قواعد البيانات المحمية. ' - استخدم المتغير العام DebugPrintEnabled لتفعيل طباعة رسائل التصحيح أثناء التجربة. ' - OpenArgs يمكن استخدامه في حدث OnLoad أو OnActivate للنموذج لمعالجة البيانات الممررة. ' - يمكن استدعاء الدالة من ماكرو باستخدام RunCode: NavigateForm() ' - إذا كان النموذج مفتوحًا، سيتم إغلاقه وإعادة فتحه بالوضع المحدد. ' - WhereCondition يتم تطبيقه عند فتح النموذج. ' - يتم منع الاستدعاءات المتكررة بنفس المعاملات فقط إذا كان النموذج مفتوحًا. ' - يتم إعادة تعيين سجل الاستدعاء بعد نجاح أو فشل العملية. ' ' المؤلف: [ابو جودي - منتديات أوفيسنا] ' تاريخ الإنشاء: 24 مايو 2025 ' الإصدار: 2.1 ' ======================================================================= Public Function NavigateForm(Optional ByVal formToClose As String = "", _ Optional ByVal formToOpen As String = "", _ Optional ByVal openMode As FormOpenMode = DefaultMode, _ Optional ByVal openArgs As Variant = Null, _ Optional ByVal WhereCondition As String = "") As Boolean On Error GoTo ErrHandler ' متغير ثابت لتتبع آخر استدعاء Static lastCall As String Dim currentCall As String currentCall = formToClose & "|" & formToOpen & "|" & openMode & "|" & IIf(IsNull(openArgs), "Null", openArgs) & "|" & WhereCondition ' التحقق من التكرار: نتجاهل فقط إذا كان النموذج مفتوحًا ونفس المعاملات If currentCall = lastCall And formToOpen <> "" Then If IsFormPresent(formToOpen) And CurrentProject.AllForms(formToOpen).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: تجاهل استدعاء متكرر بنفس المعاملات: " & currentCall End If NavigateForm = True Exit Function End If End If ' تحديث lastCall lastCall = currentCall ' افتراض النجاح NavigateForm = True ' طباعة المعاملات عند دخول الدالة If DebugPrintEnabled Then Debug.Print "NavigateForm: استدعاء الدالة مع المعاملات - formToClose: '" & formToClose & "', formToOpen: '" & formToOpen & "', openMode: " & openMode & ", openArgs: " & IIf(IsNull(openArgs), "Null", openArgs) & ", WhereCondition: '" & WhereCondition & "'" End If ' إذا لم يتم تمرير أي معاملات، أغلق النموذج الحالي If formToClose = "" And formToOpen = "" Then If Not Screen.ActiveForm Is Nothing Then If DebugPrintEnabled Then Debug.Print "NavigateForm: إغلاق النموذج الحالي '" & Screen.ActiveForm.Name & "'" End If DoCmd.Close acForm, Screen.ActiveForm.Name, acSaveNo ' إعادة تعيين lastCall بعد الإغلاق lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: لا يوجد نموذج حالي مفتوح" End If End If Exit Function End If ' التحقق إذا تم تمرير اسم نموذج للإغلاق If formToClose <> "" Then If IsFormPresent(formToClose) Then If CurrentProject.AllForms(formToClose).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: إغلاق النموذج '" & formToClose & "'" End If DoCmd.Close acForm, formToClose, acSaveNo ' إعادة تعيين lastCall بعد الإغلاق lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToClose & "' غير مفتوح" End If End If Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToClose & "' غير موجود" End If MsgBox "النموذج '" & formToClose & "' غير موجود في قاعدة البيانات.", vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الفشل lastCall = "" Exit Function End If End If ' التحقق إذا تم تمرير اسم نموذج للفتح If formToOpen <> "" Then If IsFormPresent(formToOpen) Then ' إذا كان النموذج مفتوحًا بالفعل، أغلقه If CurrentProject.AllForms(formToOpen).IsLoaded Then If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToOpen & "' مفتوح بالفعل، سيتم إغلاقه" End If DoCmd.Close acForm, formToOpen, acSaveNo End If ' فتح النموذج بالوضع المحدد If DebugPrintEnabled Then Debug.Print "NavigateForm: فتح النموذج '" & formToOpen & "' بوضع " & openMode & IIf(IsNull(openArgs), "", ", openArgs: " & openArgs) & IIf(WhereCondition = "", "", ", WhereCondition: " & WhereCondition) End If Select Case openMode Case NormalMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, , , openArgs Case DesignMode DoCmd.OpenForm formToOpen, acDesign, , WhereCondition, , , openArgs Case DatasheetMode DoCmd.OpenForm formToOpen, acFormDS, , WhereCondition, , , openArgs Case PreviewMode DoCmd.OpenForm formToOpen, acPreview, , WhereCondition, , , openArgs Case LayoutMode DoCmd.OpenForm formToOpen, acLayout, , WhereCondition, , , openArgs Case AddMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormAdd, , openArgs Case EditMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormEdit, , openArgs Case ReadOnlyMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, acFormReadOnly, , openArgs Case HiddenMode DoCmd.OpenForm formToOpen, acNormal, , WhereCondition, , acHidden, openArgs Case DialogMode DoCmd.OpenForm formToOpen, , , WhereCondition, , acDialog, openArgs Case Else DoCmd.OpenForm formToOpen, , , WhereCondition, , , openArgs End Select ' إعادة تعيين lastCall بعد فتح النموذج lastCall = "" Else If DebugPrintEnabled Then Debug.Print "NavigateForm: النموذج '" & formToOpen & "' غير موجود" End If MsgBox "النموذج '" & formToOpen & "' غير موجود في قاعدة البيانات.", vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الفشل lastCall = "" Exit Function End If End If Exit Function ErrHandler: If DebugPrintEnabled Then Debug.Print "NavigateForm: حدث خطأ: " & Err.Description End If MsgBox "حدث خطأ: " & Err.Description, vbExclamation, "خطأ" NavigateForm = False ' إعادة تعيين lastCall بعد الخطأ lastCall = "" End Function طريقة الاستخدام إنشاء الوحدة النمطية: افتح محرر VBA في (Alt + F11) أنشئ وحدة نمطية جديدة (Insert > Module) انسخ الكود أعلاه والصقه في الوحدة احفظ الوحدة النمطية باسم : basNavigateForm استدعاء الدالة: يمكن استدعاء NavigateForm من أحداث النماذج (مثل OnClick لزر) أو ماكرو أو كود VBA آخر أمثلة الاستدعاء: ' إغلاق النموذج الحالي Call NavigateForm ' إغلاق نموذج محدد Call NavigateForm("Form1") ' فتح نموذج في وضع الحوار Call NavigateForm("", "Form2", DialogMode) ' إغلاق Form1 وفتح Form2 في وضع إضافة سجل Call NavigateForm("Form1", "Form2", AddMode) ' فتح نموذج مع فلتر Call NavigateForm("", "Form2", NormalMode, , "CustomerID=123") ' فتح نموذج مع OpenArgs Call NavigateForm("", "Form2", DialogMode, "Source=MainForm") ' فتح نموذج مخفي Call NavigateForm("", "Form2", HiddenMode) ' فتح نموذج في وضع التصميم Call NavigateForm("", "Form2", DesignMode) ' فتح نموذج في عرض ورقة البيانات Call NavigateForm("", "Form2", DatasheetMode) وأخيـــــرا مرفق بسيط للتجربة NavigateForm (V2.1).accdb

جزيل الشكر على المشاركة

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

وإياكم أخي @محمد هشام. ، وأحسنتم التطوير .. لا أخفيك أنني أعشق التطوير والتحفيز لذاتي لاستنباط الإبداع من جوف الأفكار التي نملكها ويمكننا ابتكارها . وأنتم قد أحسنتم السير بهذا الطريق 👍🏻 جزاكم الله كل الخير على ترجمتكم الجميلة لفكرتي البسيطة

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @Foksh بناء على هده الفكرة القيمة قمت بتطوير الكود بحيث عند وجود أكثر من اختلاف بين القيم (قبل وبعد) يتم تمييز كل اختلاف بلون مختلف هذا فعلا يسهل جدا معرفة وتتبع الفروقات كما دكرت مع إظافة استخراج المادة التي تحتوي على الاختلاف إلى جانب الاسم والقيمة القبلية والبعدية لتوفير عرض واضح ومباشر للفروقات بالتوفيق......... نسخة معدلة من الكود لتحقيق هذا الهدف Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Long, c As Long, Tbl1, Tbl2, a, b, tmp As Long, xCount As Long, key As String Dim xColor, cnt As Object, j As Long, i As Long, x As Long, ky As String Const départ = 3, ColArr = 18, début = 2, LastCol = 9, f = 9, Irow = 1 If Target.CountLarge > 1 Then Exit Sub Set cnt = CreateObject("Scripting.Dictionary") xColor = Array( _ RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 176, 80), RGB(0, 112, 192), RGB(255, 192, 0), RGB(112, 48, 160), _ RGB(255, 0, 255), RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 102, 0), RGB(204, 0, 153), RGB(0, 255, 255), _ RGB(255, 153, 204), RGB(153, 51, 0), RGB(102, 102, 255), RGB(255, 204, 153), RGB(51, 153, 102), RGB(153, 0, 0), _ RGB(0, 102, 204), RGB(204, 153, 255), RGB(255, 255, 153), RGB(204, 0, 0), RGB(0, 153, 0), RGB(0, 51, 102), _ RGB(255, 128, 0), RGB(102, 0, 102), RGB(0, 204, 204), RGB(255, 102, 102), RGB(102, 255, 102), RGB(102, 102, 153)) On Error GoTo CleanUp With Me If Intersect(Target, .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f))) Is Nothing Then Exit Sub SetApp False .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f)).Interior.colorIndex = xlNone With .Range("T:W"): .UnMerge: .ClearContents: End With Me.[T1:W1].Value = Array("الإسم", "المادة", "قبل", "بعد") tmp = 2: j = 0: xCount = 0 For r = départ To départ + ColArr - 1 b = .Cells(r, Irow).Value For c = début To LastCol Tbl1 = .Cells(r, c).Value: Tbl2 = .Cells(r, c + f).Value: a = .Cells(2, c).Value If IsEmpty(Tbl1) Then Tbl1 = "" If IsEmpty(Tbl2) Then Tbl2 = "" If CStr(Tbl1) <> CStr(Tbl2) Then xCount = xCount + 1 key = b & "|" & a & "|" & Tbl1 & "|" & Tbl2 If Not cnt.Exists(key) Then cnt.Add key, xColor(j Mod (UBound(xColor) + 1)) j = j + 1 End If .Cells(r, c).Interior.Color = cnt(key) .Cells(r, c + f).Interior.Color = cnt(key) .Cells(tmp, "T").Resize(1, 4).Value = Array(b, a, Tbl1, Tbl2) tmp = tmp + 1 End If Next c Next r If xCount > 0 Then .Cells(tmp, "T").Value = "إجمالي الاختلافات" .Cells(tmp, "U").Value = xCount x = 2: ky = .Cells(x, "T").Value For i = 3 To tmp If .Cells(i, "T").Value <> ky Or .Cells(i, "T").Value = "" Then If i - 1 > x Then .Range("T" & x & ":T" & i - 1).Merge x = i ky = .Cells(i, "T").Value End If Next i Else With .Range("T:W"): .UnMerge: .ClearContents: End With End If CleanUp: SetApp True Set cnt = Nothing End With End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub درجات المواد v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الشهادات من " & _ début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf

جزاكم الله كل الخير .

إدا كنت ترغب في إستخدام الإقتراح المقدم من الأستاد @أبوعيد يمكنك تجربة هدا Public Property Get CrWS() As Worksheet Set CrWS = Sheets("ورقة1") End Property Private Sub UserForm_Initialize() Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long Set Tbl = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow > 1 Then For Each c In CrWS.Range("B2:B" & lastRow) If c.Value <> "" Then Tbl.Item(c.Value) = c.Value Next c End If If Tbl.Count > 0 Then temp = Tbl.items Me.ComboBox1.List = temp End If End Sub Private Sub CommandButton1_Click() Dim lastRow As Long, ky As String If Me.ComboBox1.Value <> "" Then ky = "=*" & Me.ComboBox1.Value & "*" lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False With CrWS.Range("B1:B" & lastRow) .AutoFilter Field:=1, Criteria1:=ky End With On Error Resume Next CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete On Error GoTo 0 CrWS.AutoFilterMode = False Application.ScreenUpdating = True Unload Me End If End Sub مسح صفوف معينة بناء على قيمتها v2.xlsb

وعليكم السلام تفضل أخي الكريم: Book1.xlsx