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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي 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

🛠🎁 أداة لإصلاح وتعديل النصوص العربية التالفة في الأكواد .. من > ÇáÓáÇã Úáíßã إلى > السلام عليكم :: السلام عليكم ورحمة الله وبركاته :: نظرا لوجود مشكلة عند نسخ النصوص العربية في أكواد VBA وخصوصا عندما تكون لغة النظام معينة على اللغة الإنجليزية .. لذلك قمت بتصميم هذه الأداة لتقوم بإصلاح العبارات العربية التالفة في الكود وإرجاعها إلى أصلها ... مثال : ÇáÓáÇã Úáíßã >>>> تعود لأصلها : السلام عليكم وهذه صورة للأداة : اعرض الملف صاحب الملف Moosak تمت الاضافه 04/22/25 الاقسام قسم الأكسيس

من المفروض أولا كما سبق الدكر محاولة إلغاء دمج الخلايا لضمان أن الكود يتعامل مع كل خلية على حدة وحصولك على نتائج صحيحة جرب هدا هل يناسيك Option Explicit Public Sub Add_CheckBoxes() Dim tbl As Long, cb As OLEObject, OnRng As Range, ky As Variant Dim dataArray() As String, Search As String, n As Boolean Dim i As Long, lastRow As Long, col As Long, lastCol As Long Dim kys() As String Dim CrWS As Worksheet: Set CrWS = Sheets("MenuF") Dim dest As Worksheet: Set dest = Sheets("main sheet") Search = Trim(CrWS.Range("B1").Value) If Search = "" Then: MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub lastRow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row n = False For i = 2 To lastRow If Trim(dest.Cells(i, 1).Value) = Search Then tbl = i n = True Exit For End If Next i If Not n Then: MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation: Exit Sub lastCol = dest.Cells(tbl, Columns.Count).End(xlToLeft).Column ReDim dataArray(1 To lastCol - 1) For col = 2 To lastCol dataArray(col - 1) = Trim(dest.Cells(tbl, col).Value) Next col For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then cb.Object.Value = False Next cb For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "،", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb End If Next i Next ky End If Next OnRng End Sub Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function Private Function CompareValues(val1 As String, val2 As String) As Boolean CompareValues = (InStr(1, val1, val2, vbTextCompare) > 0 Or InStr(1, val2, val1, vbTextCompare) > 0) End Function لتلوين القيم CrWS.Range("A3:I7").Font.Color = vbBlack For Each OnRng In CrWS.Range("A3:I7") If OnRng.Value <> "" Then kys = Split(Replace(OnRng.Value, "?", ","), ",") For Each ky In kys For i = LBound(dataArray) To UBound(dataArray) If CompareValues(tmp(dataArray(i)), tmp(ky)) Then For Each cb In CrWS.OLEObjects If TypeName(cb.Object) = "CheckBox" Then If cb.TopLeftCell.Address = OnRng.Address Then cb.Object.Value = True Exit For End If End If Next cb OnRng.Font.Color = vbRed End If Next i Next ky يمكنك إختيار ما يناسبك فورمة - V4.xlsb

معلمي وأستاذي الفاضل / محمد صالح السلام عليكم ورحمة الله وبركاته لقد أثلج صدري تعليقكم الذي هو بمثابة بلسم يداوي الجروح ولكن أحببنا فقط أن نلفت الانتباه لحسن الأسلوب في التوجيه لما قد نغفل عنه أحيانا دون قصد أو عمد. ولنا في سيدنا رسول الله (صل الله عليه وسلم) أسوة حسنة حينما قال ربنا سبحانه وتعالى في محكم كتابه الكريم قرآنا يتلى إلى أن يرث الله الأرض ومن عليها في حق رسولنا الكريم: (فَبِمَا رَحۡمَةٖ مِّنَ ٱللَّهِ لِنتَ لَهُمۡۖ وَلَوۡ كُنتَ فَظًّا غَلِيظَ ٱلۡقَلۡبِ لَٱنفَضُّواْ مِنۡ حَوۡلِكَۖ ...) آل عمران (159) § ولله الحمد والمنة أنه تم استبدال عبارة (أفضل إجابة) بعبارة (تمت الإجابة) فكل من أدلى بدلوه يستحق كل الشكر وعظيم الاحترام والتقدير؛ وكوني كنت معلما فأعرف للمعلم قدره جيدا وتبجليه؛ ولله در الشاعر (أحمد شوقي) حينما قال: قُم لِلمُعَلِّمِ وَفِّهِ التَبجيلا ... كادَ المُعَلِّمُ أَن يَكونَ رَسولا أَعَلِمتَ أَشرَفَ أَو أَجَلَّ مِنَ الَّذي ... يَبني وَيُنشِئُ أَنفُساً وَعُقولا سُبحانَكَ اللَهُمَّ خَيرَ مُعَلِّمٍ ... عَلَّمتَ بِالقَلَمِ القُرونَ الأولى § وأشهد الله أن في هذا المنتدى المحبب إلى قلبي ونفسي من جاوبنا وعلمنا ما جهلنا دون أن يعرف بعضنا بعضا بصفة شخصية؛ وإن تقابلت الوجوه يوما ما لقبلت رؤوسهم وأيديهم تقديرا واحتراما لفضلهم علينا وكيف لا و (من علمني حرفا صرت له عبدا) وأذكر منهم: ü الأستاذ الفاضل / ابراهيم الحداد ü الأستاذ الفاضل / محمد صالح ü الأستاذ الفاضل / Ali Mohamed Ali ü الأستاذ الفاضل / محمد هشام. ü الأستاذ الفاضل / عبدالله بشير عبدالله فلكم جميعا مني كل الشكر و التقدير والاحترام وجزاكم الله عنا خير الجزاء. v أستاذي الفاضل / محمد صالح ما أجمل قولك حينما ختمت أحد موضوعاتك الرائعة: لو بخل بها غيرك ما وصلت إليك ... فلا تبخل بها على غيرك بعد معرفتك بها v وأذكر في هذا المقام: · (... عن علمه فيما عمل به ...) · (تعلم فليس المرء يولد عالما ... وليس أخو علم كمن هو جاهل) v أما وإن ذكرت قول الله تعالى: (... وَلۡيَعۡفُواْ وَلۡيَصۡفَحُوٓاْۗ أَلَا تُحِبُّونَ أَن يَغۡفِرَ ٱللَّهُ لَكُمۡۚ وَٱللَّهُ غَفُورٞ رَّحِيمٌ) النور (22) فقد عفونا. (انتهى)

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تنفيذ ذلك باستخدام الأكواد ولكن أعتقد أنه سيكون من الضروري أولا تنظيم البيانات في ورقة العمل Menuf بشكل جيد ومن الأفضل كذلك فك الخلايا المدمجة لضمان الحصول على نتائج دقيقة ووضع الدوائر حول القيم المطلوبة بشكل صحيح إذا كان هذا يناسبك فالكود التالي ربما يساعدك في تنفيذ طلبك ' تحديد عرض الدائرة Const xWidth As Single = 40 ' تحديد طول الدائرة Const xlength As Single = 55 Sub AddDrawCircles() Dim dest As Worksheet, CrWS As Worksheet Dim Search As String, dataValue As String Dim ColArr As Long, lastRow As Long, i As Long, col As Long Dim cell As Range, OnRng As Range, shp As Shape, lastCol As Long Dim n As Boolean, a() As String, ky As Variant, r() As String On Error GoTo SupApp Set CrWS = Sheets("main sheet"): Set dest = Sheets("MenuF") Search = Trim(dest.[B1].Value) If Search = "" Then MsgBox "يرجى إدخال قيمة البحث", vbExclamation: Exit Sub SetApp False lastRow = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(CrWS.Cells(i, 1).Value) = Search Then ColArr = i: n = True: Exit For Next i If Not n Then MsgBox "قيمة البحث غير موجودة على قاعدة البيانات", vbExclamation, "إنتبـــاه": GoTo CleanUp For Each shp In dest.Shapes: If Left(shp.Name, 4) = "Oval" Then shp.Delete Next shp lastCol = CrWS.Cells(ColArr, Columns.Count).End(xlToLeft).Column ReDim a(1 To lastCol - 1) For col = 2 To lastCol: a(col - 1) = Trim(CrWS.Cells(ColArr, col).Value): Next col Set OnRng = dest.Range("A3:I7") For col = 1 To 6 dataValue = a(col) If dataValue <> "" Then For Each cell In OnRng If cell.Value <> "" Then r = Split(Replace(cell.Value, "،", ","), ",") For Each ky In r If CompareValues(tmp(ky), tmp(dataValue)) Then DrawCircle cell: Exit For Next ky End If Next cell End If Next col CleanUp: SetApp True Exit Sub SupApp: Resume ExitSub ExitSub: End Sub '""""""""""""""""""""""""""""" Private Function tmp(ByVal txt As String) As String tmp = Replace(Replace(Trim(txt), " ", " "), "ال", "") End Function '"""""""""""""""""""""""""""" Private Function CompareValues(value1 As String, value2 As String) As Boolean CompareValues = (InStr(1, value1, value2, vbTextCompare) > 0 Or InStr(1, value2, value1, vbTextCompare) > 0) End Function '""""""""""""""""""""""""""""""""""""""""" Private Sub DrawCircle(cell As Range) With cell.Worksheet.Shapes.AddShape(msoShapeOval, _ cell.Left + (cell.Width - xlength) / 2, _ cell.Top + (cell.Height - xWidth) / 2, _ xlength, xWidth) .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) .Line.Weight = 1.5 .Name = "Oval_" & cell.Address(False, False) End With End Sub '""""""""""""""""""""""""""" Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub وفي حدث ورقة Menuf Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B1")) Is Nothing Then AddDrawCircles End If End Sub فورمة - V2.xlsb

إدن لنجرب هدا Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const ky As Long = 5: Const timeCol As Long = 4 Const colName As Long = 2: Const iRow As Long = 7 Const xCOLOR As Long = 42495: Const lastCol As Long = 34 Dim lastRow As Long, i As Long, col As Long, r As Long, n As Long Dim tmps As Boolean, xWeekend As Boolean, sDate As Date, cnt As Date Dim key As String, sName As String, dayName As String, status As String Dim OnRng As Variant, rng As Variant, cnts As Variant, tmp As Object, j As Object Dim Icon As String, xAbsen As String, name As String, sTime As String, a As Range Icon = ChrW(&H2705): xAbsen = ChrW(&H274C) Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") lastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row Set tmp = CreateObject("Scripting.Dictionary") Set j = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With For r = 4 To CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row If Trim(CrWS.Cells(r, 3).Value) = "عطلة" Then tmp(CLng(CrWS.Cells(r, 1).Value)) = True End If Next For r = 4 To CrWS.Cells(CrWS.Rows.Count, 5).End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" Then name = Trim(CrWS.Cells(r, 5).Value) sDate = CrWS.Cells(r, 6).Value sTime = Trim(CrWS.Cells(r, 9).Value) status = Trim(CrWS.Cells(r, 7).Value) key = name & "|" & CLng(sDate) & "|" & sTime j(key) = status If sTime = "صباحي/مسائي" Then j(name & "|" & CLng(sDate) & "|صباحي") = status j(name & "|" & CLng(sDate) & "|مسائي") = status End If End If Next OnRng = dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value cnts = dest.Range(dest.Cells(ky, 5), dest.Cells(ky, lastCol)).Value rng = dest.Range(dest.Cells(ky + 1, 5), dest.Cells(ky + 1, lastCol)).Value For i = 1 To UBound(OnRng, 1) If Trim(OnRng(i, colName)) <> "" Then sName = Trim(OnRng(i, colName)) For col = 5 To lastCol n = col - 4 If IsDate(cnts(1, n)) Then cnt = cnts(1, n): dayName = rng(1, n) tmps = tmp.exists(CLng(cnt)) xWeekend = (dayName = "الجمعة" Or dayName = "السبت") sTime = Trim(OnRng(i, timeCol)) key = sName & "|" & CLng(cnt) & "|" & sTime status = IIf(j.exists(key), j(key), "") If tmps Or xWeekend Or status = "غائب" Or status = "مجاز" Or status = "متأخر" Then OnRng(i, col) = xAbsen Else OnRng(i, col) = Icon End If End If Next col Next i dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value = OnRng With dest.Range(dest.Cells(iRow, 5), dest.Cells(lastRow, lastCol)) .Font.name = FontName: .Font.Bold = True .Interior.ColorIndex = -4142: .Font.Color = vbGreen For Each a In .Cells If a.Value = xAbsen Then a.Font.Color = vbRed a.Interior.Color = xCOLOR End If Next a End With With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم التحديث البيانات بنجاح", vbInformation Exit Sub SupApp: With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub استمارة-بعض النتائج المطلوبة v2.xlsb

مشاركة مع استاذى الجليل و معلمى القدير الاستاذ @ابو عارف وبعد إذن أستاذى هناك بعض الحالات التي قد تستوجب تعديلات إضافية لضمان التوافق بين الأنوية المختلفة (32 بت و 64 بت) وكذلك بين إصدارات الويندوز وأوفيس المختلفة عند التعامل مع دوال الـ API في VBA و يجب الانتباه لها: في النظام 32 بت، النوع Long يستخدم بشكل طبيعي لتخزين المؤشرات (pointers)، لكن في النظام 64 بت، يجب استخدام LongPtr بدلاً من Long لتخزين المؤشرات. المشكلة: إذا لم تستخدم LongPtr في النظام 64 بت، فقد تحدث أخطاء في الحسابات التي تتعلق بالحجم أو العناوين، لأن الـ Long لا يدعم العناوين الأكبر في الأنظمة 64 بت. ملاحظة: في الأنظمة 64 بت، LongPtr قادر على التعامل مع الأرقام التي تتجاوز سعة الـ Long العادية (التي تصل إلى 2,147,483,647). في الأنظمة 32 بت، LongPtr يتم تحديده تلقائيًا ليكون Long. التعامل مع السلاسل النصية (Strings) في بعض الأحيان، قد تحتاج إلى تعديل طريقة تعريف السلاسل النصية المستخدمة مع الـ API إذا كنت تستخدم سلاسل نصية مع الـ API، تأكد من إضافة ByVal و ByRef بشكل صحيح استخدم String * n بدلاً من String في بعض الحالات التي تتطلب أن تكون السلسلة ثابتة الطول التعامل مع الهياكل (Structures) في بعض الأحيان، تستخدم الهياكل (مثل Type في VBA) مع دوال الـ API. إذا كنت تستخدم هياكل كبيرة، فقد تحتاج إلى التأكد من أن الأنواع داخلها متوافقة مع النظام 64 بت تأكد من أن جميع الهياكل تتعامل بشكل صحيح مع الأنواع مثل LongPtr بدلاً من Long أو Integer عندما يتعلق الأمر بالمؤشرات لأنه قد يتغير حجم الحقول في الهيكل بين الأنوية 32 و 64 بت، مما يسبب أخطاء في التعامل مع الذاكرة أو المؤشرات التأكد من استخدام #If و #ElseIf بشكل مناسب عند التعامل مع دوال API في VBA وتحديد التوافق بين الأنظمة 32 بت و 64 بت، تأكد من استخدام #If, #ElseIf و #End If بشكل صحيح عند تخصيص الوظائف للأجهزة ذات الأنوية المختلفة. الشرح السابق يوضح الفرق فى التعامل مع النواتان و كتابة الكود بشكل صحيح ليصبح الكود متوافقا بين النواتان لانه لو قمت بالاستبدال لن يعمل على النواة 32

عدل هنا تنسيق التاريخ بما يناسبك For i = 1 To OnRng For j = 0 To UBound(colVisu) cnt(i, j + 1) = TblBD(i, colVisu(j)) تنسيق التاريخ If IsDate(cnt(i, j + 1)) Then cnt(i, j + 1) = Format(cnt(i, j + 1), "dd/mm/yy") <=========== Next j Next i الى If IsDate(cnt(i, j + 1)) Then cnt(i, j + 1) = Format(cnt(i, j + 1), "dd/mm/yyyy")

نعم أخي يمكننا فعل دالك للتوضيح : تم إظافة تحديث الإسم الكامل للموظف عند الإدخال مباشرة للمعاينة فقط لأنه في الأصل يحدث عند كل ترحيل أو تعديل للبيانات المرفقات https://www.mediafire.com/file/bq3nkauzlo9j3jt/بيانات+الموظفين+v2.rar/file تم رفعه في المشاركه قاعدة بيانات الموظفين 2 .xlsm بيانات الموظفين v2.rar

السلام عليكم ورحمة الله تعالى وبركاته أعتذر على التأخير في الرد فقد كنت في إجازة كما ذكرت سابقا 😃 بعد محاولتي المتواضعة لتعديل الملف أتمنى أن أكون قد وفقت في فهم طلبك وتنفيذه بالشكل المطلوب أعتذر أيضا على الإطالة لكن كان من الضروري توضيح بعض النقاط المهمة التي تم إدراجها في الملف حتى تتمكن من التعامل معه بسلاسة وتعديله لاحقا بما يتناسب مع احتياجاتك 1) بناء على طلبك تم تعديل طريقة جلب البيانات بحيث تعتمد الآن على نطاق A:U، وتم حذف الجدول السابق كما تم عرض جميع الأعمدة على ListBox التي تحتوي على 21 عمود Set WsRng = WS.Range("A2:U" & WS.Cells(WS.Rows.Count, 2).End(xlUp).row) 2) بما أنك طلبت إضافة اسم المستخدم وتاريخ التعديل أو الحذف لغرض المتابعة فهذا يعني أن الملف سيستخدم من قبل أكثر من مستخدم لذلك تم تعديل شاشة تسجيل الدخول الخاصة بالمستخدمين لتتناسب مع دالك عبر إنشاء ورقة جديدة باسم "Users" والتي ستكون مرئية فقط لمسؤول النظام (Admin) من خلالها يمكنك تحديد أسماء المستخدمين وكلمات المرور الخاصة بهم بما يتناسب مع احتياجاتك بعد كل عملية دخول سيتم إظافة إسم المستخدم ووقت الدخول في نفس الورقة على الأعمدة J:K 3) تمت إضافة ورقة خاصة لتتبع جميع التعديلات التي تطرأ على الملف بحيث توضح: القيم السابقة / القيم الجديدة / تاريخ التعديل / واسم المستخدم الذي قام بالعملية كما هو موضّح في الصورة أدناه 4) تمت إضافة ورقة خاصة بالمحذوفات وذلك استجابة لطلبك بالاحتفاظ بجميع البيانات التي يتم حذفها تحتوي هذه الورقة على معلومات تفصيلية تشمل: البيانات المحذوفة / اسم المستخدم الذي قام بالحذف / وتاريخ العملية تجدر الإشارة إلى أن كل من: ورقة التعديلات / ورقة المحذوفات / بطاقة الموظف ستكون مخفية عن المستخدمين العاديين ولن تكون مرئية إلا لمسؤول النظام (Admin) فقط وذلك لضمان سرية البيانات وحمايتها من التعديل أو الحذف غير المصرح به نظرا أن نطاق البيانات كبير يمكنك فتح (UserForm) عبر الضغط مرتين على أي خلية في الصف الأول 6) إمكانية إضافة صورة الموظف من أي مكان على الجهاز حسب اختيارك دون التقيد بمسار محدد الصيغ المسموح بها: JPG- JPEG- PNG- BMP- GIF 7) ترحيل بيانات الموظف مع ضمان عدم تكرار الرقم الوطني: في حال وجود رقم وطني مكرر يتم تنبيه المستخدم عند نجاح الترحيل تضاف البيانات ويتم تسطيرها تلقائيا وإظافة التسلسل على عمود A كما طلبت يتم إنشاء مجلد رئيسي باسم "المرفقات" (في حال لم يكن موجودا) وبداخله مجلد فرعي يحمل الرقم الوطني للموظف وتحفظ الصورة داخله (في حال تم اختيار صورة) وقد تم تنفيد نفس الفكرة بالنسبة لملفات PDF 😎 عند تعديل بيانات الموظف: يتم تحديث البيانات (بما في ذلك الصورة إذا تم تغييرها) يتم ترحيل البيانات السابقة والجديدة إلى ورقة التعديلات لتوثيق التغييرات 9) حذف بيانات الموظف: يتم حذف كافة بياناته من قاعدة البيانات كما يتم حذف المرفقات الخاصة به (سواء كانت صورا أو ملفات PDF) من المجلد الخاص به داخل "المرفقات" تحديث التسلسل 10) معاينة المرفقات بسهولة: يمكنك معاينة صورة الموظف مباشرة من ListBox بالنقر المزدوج (Double Click) إذا كانت الصورة مضافة مسبقا كما يمكنك فتح مجلد المرفقات بالكامل باستخدام زر مخصص (مجلد المرفقات) للاطلاع على جميع المجلدات و الملفات المتوفرة سواءا الصور أو بطائق PDF 11) حفظ تقرير PDF لبطاقة الموظف عند تحديده من قائمة الموظفين (ListBox) يتم إنشاء التقرير بصيغة PDF بمجرد تحديد الموظف من داخل LISTBOX (بناءا على الرقم الوطني) عمود E ويحفظ داخل مجلد خاص بإسم الموظف تم إظافة يوزرفورم جديد يمكنك من عرض ملفات PDF من خلاله التقرير يحتوي على جميع بيانات الموظف من العمود A إلى العمود U بطريقة منظمة وجاهزة للطباعة أو الحفظ ( يمكنك تعديله بما يناسبك) 12) حذف تلقائي لمرفقات الموظف عند حذف بياناته: في حال تم حذف الموظف من النظام يتم أيضا حذف بطاقة الموظف (PDF) الخاصة به تلقائيا إلى جانب المرفقات (الصورة أو ملفات أخرى) 13) تم تعويض معادلة دمج إسم الموظف الكامل بالأكواد مع تحديثها تلقائيا عند التعديل بالتوفيق............ للتجربة قم بنسخ المجلدات (تقارير الموظفين pdf + المرفقات ) بعد فك الظغط إلى نفس مسار المصنف وفي حال وجود أي استفسار- تعديل إضافي أو ملاحظات - سنكون دائما سعداء للمساعدة والتوضيح🌿 "لا تنسونا من صالح دعائكم – [أخوك في الله محمد هشام] قاعدة بيانات الموظفين .xlsm بيانات الموظفين v2.rar

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

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك Option Explicit Sub Extract_Names2() Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) With CrWS.Range("D2:E" & CrWS.Rows.Count) .ClearContents: .Borders.LineStyle = xlNone End With Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB tbl = tmp.Value If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1 Next tmp début = 3: dCount = 0 For Each tmp In ColA tbl = tmp.Value If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tbl CrWS.Cells(début, 5).Value = tbl dict.Remove tbl: début = début + 1: dCount = dCount + 1 End If Next tmp ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1) UniCount = 0 For Each Key In dict.Keys CrWS.Cells(ColE, 5).Value = Key ColE = ColE + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit On Error Resume Next CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete On Error GoTo 0 With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count) .FormatConditions.Add Type:=xlExpression, _ Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)" .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193) End With Irow = Application.WorksheetFunction.Max( _ CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row) a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then With CrWS.Cells(i + 2, 4).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If If b(i, 1) <> "" Then With CrWS.Cells(i + 2, 5).Borders .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic End With End If Next i With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك Option Explicit Sub Extract_Names() Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr) For Each tmp In ColB If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row Next tmp CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In ColA If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value dict.Remove tmp.Value début = début + 1 dCount = dCount + 1 End If Next tmp For Each tmp In ColB If dict.exists(tmp.Value) Then CrWS.Cells(début, 3).Value = tmp.Value début = début + 1 UniCount = UniCount + 1 End If Next tmp CrWS.Range("C2").Value = " عدد الوظائف / المتشابهة: " & dCount & " & الفردية: " & UniCount CrWS.Columns("C:C").EntireColumn.AutoFit Set dict = Nothing With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub Book2 v2.xlsb

Dim Sh As Boolean Public Property Get f() As Worksheet Set f = Sheets("Sheet1") <========= إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها End Property Private Sub UserForm_Initialize() Dim WS As Worksheet, CrWS As Variant, i As Integer ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها CrWS = Array("Sheet1", "Sheet2", "Sheet3") For Each WS In ThisWorkbook.Worksheets For i = LBound(CrWS) To UBound(CrWS) If WS.name = CrWS(i) Then ListBox1.AddItem WS.name Exit For End If Next i Next WS HideBar Me End Sub Private Sub CommandButton1_Click() Dim i As Integer, ShName As String, newWb As Workbook, sPath As String Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String WBname = f.[R2].Value <======= قم بتعديل عنوان خلية الإسم بما يناسبك If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub 'Code........ .............. End Sub Private Sub CommandButton2_Click() On Error GoTo SupApp Dim arr As New Collection, TempWb As Workbook, WS As Worksheet Dim i As Integer, sMsg As Integer, tbl As Boolean Dim WBname As String, sPath As String, shArr As String WBname = Trim(f.Range("R2").Value) If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub tbl = Me.CheckBox1.Value For i = 0 To Me.ListBox1.ListCount - 1 If tbl Or Me.ListBox1.Selected(i) Then arr.Add Me.ListBox1.List(i) shArr = shArr & Me.ListBox1.List(i) & "- " sMsg = sMsg + 1 End If Next If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub If Len(shArr) > 0 Then shArr = Left(shArr, Len(shArr) - 2) End If If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _ vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub With Application .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Set TempWb = Workbooks.Add(xlWBATWorksheet) For i = 1 To arr.Count ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count) Next sPath = ThisWorkbook.path & "\" & WBname & ".pdf" If Dir(sPath) <> "" Then Kill sPath TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False TempWb.Close False MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ" Unload Me CleanUp: With Application .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With Exit Sub SupApp: On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False Resume CleanUp End Sub تصدير صفحات v3.xlsm

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

السلام عليكم عاااااش والله لم يخطر على بالى ان ممكن نرجع الهيلوغريفى ده لعربى وكمان لم يخطر على بالى ابحث عن حل هذه المشكلة الله عليك عاش بجد شوف يا استاذنا الغالى انت لازم تعمل لعنصر التحكم اللى هيتم اللصق له او النسخ منه : SetFocus وده مهم ولابد قبل استخدام الاوامر التاليه DoCmd.RunCommand acCmdPaste أو DoCmd.RunCommand acCmdCopy مفيش حاجه اسمها على نسخة الأوفيس 365 أن هذولا السطرين ما يشتغلوا يعنى بالنسبه لمثالك بكل بساطه ده شكل كود النسخ Me.Weard_ResTxt.SetFocus DoCmd.RunCommand acCmdCopy MsgOut "تم النسخ" وده شكل كود اللصق Me.Weard_ResTxt = "" Me.Weard_OrgTxt = "" Me.Weard_OrgTxt.SetFocus DoCmd.RunCommand acCmdPaste

وعليكم السلام ورحمة الله وبركانه اليك الملف وبه التعديل ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 5.xlsb وان اردت اي تعديل في الملف فايشر لك كل الود والاحترام

وعليكم السلام ورحمة الله تعالى وبركاته هذا يتطلب ببساطة تحديد حجم ثابت للدوائر بدلا من حسابه بناء على حجم الخلايا يمكنك تغيير هذه القيمة حسب الحجم الذي ترغب فيه tmp = 10 Option Explicit Sub DrawCircles() Const SROW As Long = 6, EROW As Long = 10, SCOL As Long = 2, ECOL As Long = 9 Dim ws As Worksheet, sColName As String, i As Long, j As Long, n As Long, tmp As Double Application.ScreenUpdating = False Call DelShap Set ws = ActiveSheet tmp = 10 For i = SROW To EROW With ws n = .Range("k" & i).Value For j = ECOL To SCOL Step -1 If .Range(.Cells(i, j).Address).Value <> Empty And n > 0 Then sColName = Split(.Cells(1, j).Address, "$")(1) With ActiveSheet.Shapes.AddShape(msoShapeOval, _ .Range(sColName & i).Left + 0.5 * (.Range(sColName & i).Width - 2 * tmp), _ .Range(sColName & i).Top + 0.5 * (.Range(sColName & i).Height - 2 * tmp), _ 2 * tmp, 2 * tmp) .Line.Weight = 2 .Line.ForeColor.RGB = RGB(10, 10, 10) .Fill.Visible = msoFalse End With n = n - 1 End If If n = 0 Then Exit For Next j End With Next i Application.ScreenUpdating = True End Sub

نعم أخي @نبا زيد يمكننا فعل دالك لاكن لدي إقتراح أعتقد أنه أفضل بدلا من تعديل الألوان مباشرة في الكود كل مرة يمكنك تحديد ألوان الخلفية ولون الخط بسهولة من داخل ورقة تمت إظافتها للملف بإسم الإعدادات كما هو موضح في الصورة التالية كل ما عليك فعله هو 1) تحديد اسم الحالة في العمود A مثل غائب - متأخر - مجاز - عطلة - حاضر - نهاية الأسبوع 2) اختيار اللون المناسب للخلفية في العمود B 3) اختيار اللون المناسب للخط في العمود C كل حالة سيتم تلوينها تلقائيا بناء على الألوان التي تحددها في ورقة الإعدادات مما يتيح لك تعديل الألوان في أي وقت بما يتناسب مع احتياجاتك دون التأثير على الكود أتمنى أن تجد هذه الفكرة مفيدة بالتوفيق Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const StartCol As Long = 5, TimeCol As Long = 4, NamArr As Long = 2 Const StartRow As Long = 7, LastCol As Long = 34 Dim xTime As String, Snt As String, Key As String, Icon As String Dim tmp As Object, tbl As Object, xColor As Object, xFont As Object Dim xAbsen As String, xName As String, DayName As String, Status As String Dim LastRow As Long, i As Long, col As Long, r As Long, n As Long, xDate As Date Dim f As Boolean, sWeekend As Boolean, a As Variant, b As Variant, c As Variant, j As Range Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") Dim WsSet As Worksheet: Set WsSet = Sheets("الإعدادات") Icon = ChrW(&H2714): xAbsen = ChrW(&H274C) Set tmp = CreateObject("Scripting.Dictionary") Set tbl = CreateObject("Scripting.Dictionary") Set xColor = CreateObject("Scripting.Dictionary") Set xFont = CreateObject("Scripting.Dictionary") For r = 2 To WsSet.Cells(WsSet.Rows.Count, "A").End(xlUp).Row Dim OnRng As String: OnRng = Trim(WsSet.Cells(r, 1).Value) If OnRng <> "" Then xColor(OnRng) = WsSet.Cells(r, 2).Interior.Color xFont(OnRng) = WsSet.Cells(r, 3).Interior.Color End If Next r SetApp False For r = 4 To CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row If Trim(CrWS.Cells(r, 3).Value) = "عطلة" Then tmp(CLng(CrWS.Cells(r, 1).Value)) = True Next r For r = 4 To CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" And IsDate(CrWS.Cells(r, 6).Value) Then xName = Trim(CrWS.Cells(r, 5).Value) xDate = CrWS.Cells(r, 6).Value xTime = Trim(CrWS.Cells(r, 9).Value) Status = Trim(CrWS.Cells(r, 7).Value) Key = xName & "|" & CLng(xDate) & "|" & xTime tbl(Key) = Status If xTime = "صباحي/مسائي" Then tbl(xName & "|" & CLng(xDate) & "|صباحي") = Status tbl(xName & "|" & CLng(xDate) & "|مسائي") = Status End If End If Next r LastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row a = dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value b = dest.Range(dest.Cells(5, StartCol), dest.Cells(5, LastCol)).Value c = dest.Range(dest.Cells(6, StartCol), dest.Cells(6, LastCol)).Value For i = 1 To UBound(a, 1) If Trim(a(i, NamArr)) <> "" Then xName = Trim(a(i, NamArr)) For col = StartCol To LastCol n = col - StartCol + 1 If IsDate(b(1, n)) Then xDate = b(1, n): DayName = c(1, n): f = tmp.exists(CLng(xDate)) sWeekend = (DayName = "الجمعة" Or DayName = "السبت") xTime = Trim(a(i, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") a(i, col) = IIf(f Or sWeekend Or Status = "غائب" Or _ Status = "مجاز" Or Status = "متأخر", xAbsen, Icon) End If Next col Next i dest.Range(dest.Cells(StartRow, 1), dest.Cells(LastRow, LastCol)).Value = a With dest.Range(dest.Cells(StartRow, StartCol), dest.Cells(LastRow, LastCol)) .Font.Name = FontName: .Font.Bold = True .Font.Color = vbBlack: .Interior.ColorIndex = xlNone For Each j In .Cells If j.Value = Icon Then If xColor.exists("حاضر") Then j.Interior.Color = xColor("حاضر") If xFont.exists("حاضر") Then j.Font.Color = xFont("حاضر") ElseIf j.Value = xAbsen Then Dim ColArr As Long: ColArr = j.Column - StartCol + 1 Dim RowArr As Long: RowArr = j.Row - StartRow + 1 xDate = b(1, ColArr) If Trim(a(RowArr, NamArr)) <> "" Then xName = Trim(a(RowArr, NamArr)) xTime = Trim(a(RowArr, TimeCol)) Key = xName & "|" & CLng(xDate) & "|" & xTime Status = IIf(tbl.exists(Key), tbl(Key), "") Snt = IIf(tmp.exists(CLng(xDate)), "عطلة", IIf(c(1, ColArr) = "الجمعة" Or _ c(1, ColArr) = "السبت", "نهاية الأسبوع", Status)) If xColor.exists(Snt) Then j.Interior.Color = xColor(Snt) If xFont.exists(Snt) Then j.Font.Color = xFont(Snt) End If Next j End With ExitSub: SetApp True MsgBox "تم تحديث البيانات بنجاح", vbInformation Exit Sub SupApp: Resume ExitSub End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End Sub استمارة-بعض النتائج المطلوبة v3.xlsb

وعليكم السلام ورحمة الله وبركانه الكود يقوم بفرز الاسماء المكررة ويضعها في العمود C Sub تجميع() Dim ws As Worksheet Dim lastRow As Long, i As Long, j As Long Dim dict As Object Dim name As Variant, location As String Dim outputRow As Long Set ws = ActiveSheet Set dict = CreateObject("Scripting.Dictionary") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow name = ws.Cells(i, 1).Value location = ws.Cells(i, 2).Value If name <> "" Then If dict.Exists(name) Then dict(name) = dict(name) & " / " & location Else dict(name) = location End If End If Next i ws.Range("C1:D" & ws.Rows.Count).ClearContents outputRow = 1 For Each name In dict.Keys ws.Cells(outputRow, 3).Value = name ws.Cells(outputRow, 4).Value = dict(name) outputRow = outputRow + 1 Next name End Sub Book2.xlsb

عين الصواب ، واعتقد انه حل مثالي .. وتطبيقاً كما أشار معلمنا الجليل @ابوخليل ، قمت بانشاء 4 حقول في الجدول Tbl_saf كالآتي :- EnteredBy SpellingReviewedBy WrittenBy WritingReviewedBy حقول نصية ، وقمت باضافة 4 مربعات نص في التقرير في الجزء PageFooterSection ، وتم استخدام الدالة Dlookup كالآتي :- Tx05 : =DLookUp("EnteredBy","Tbl_saf","safType = '" & [Combo5] & "'") Tx06 : =DLookUp("SpellingReviewedBy","Tbl_saf","safType = '" & [Combo5] & "'") Tx07 : =DLookUp("WrittenBy","Tbl_saf","safType = '" & [Combo5] & "'") Tx08 : =DLookUp("WritingReviewedBy","Tbl_saf","safType = '" & [Combo5] & "'") حيث تم الاعتماد على الكومبوبوكس Combo5 كشرط لمعرف الصف Database35.zip

عذرا طلبك واضح ولكنى لم انتبه عن طريق كود كتابة اسماء الفصول بالارقام العربية.xlsb

السلام عليكم ورحمة الله وبركاته أستاذ الفاضل @algammal علمناك دائما واسع الصدر طويل البال ولا يختلف أحد على عزة نفس الجميع في هذا الصرح وحضرتك أولهم وكلنا يتواصل مع الأصدقاء في هذا الصرح بروحه لأننا ربما لا نعرف بعضنا معرفة شخصية في الواقع ولذا نلتمس لبعضنا العذر في اختلاف الثقافات والبيئات فلا أعتقد أن الصديق الذي ارسل لحضرتك هذه الرسالة يقصد الإساءة لحضرتك ولكنه يقصد فقط أن نتعاون جميعا ويدعم بعضنا بعضا ونكون سببا في الارتقاء بأنفسنا واعذرني في تحليلي لنص الرسالة بطريقة مختلفة: الأخ صاحب الرسالة يريدك فقط أن تدعم من قام بالإجابة بالضغط على زر الإعجاب وزر أفضل إجابة (وهذه نواحي تنظيمية لمحتوى المنتدى) وهو مما يزيد شعبية من أجاب طلب حضرتك وترتيبه في المنتدى وكل هذا دعما معنويا للمجيب. ومن باب هل جزاء الإحسان إلا الإحسان كلنا ندعم صاحب الرد الجميل بالإعجاب حتى وإن لم يكن أفضل إجابة. وفي الأخير أذكر نفسي وجميع اصدقائي بقول الله تعالى: وَلْيَعْفُوا وَلْيَصْفَحُوا ۗ أَلَا تُحِبُّونَ أَن يَغْفِرَ اللَّهُ لَكُمْ ۗ وَاللَّهُ غَفُورٌ رَّحِيمٌ. جعلنا الله جميعا ممن يحسنون الحديث ويقولون قولا يسلمون فيه من الاثم والأذى وكل عام وأنتم جميعا بخير وصحة وسعادة

وعليكم السلام ورحمة الله وبركاته نم النظر في جميع الملاحظات وتم التعديل ان شاء الله مع ملاحظة اعادة معادلة الترقيم في شيت معاشات كنت جعلت الترقيم تلقائى لجعل الكود اسرع قحسب طلبك العدد سيكون اكثر من 10000 ومن اسباب ثقل الاكواد المعادلات وخاصة ان شيت DATA سيكون به اكثر من 70000 معادلة اذا كان عدد الموظفين اكثر من 10000 وعلى كل حال مواصفات الجهاز الجيدة لها دور كبير في سرعة معالجة البياتان اتمنى ان تجد طلبك في الملف ولا حرج في اي ملاحظات تراها تخدم العمل في ملفك حفظك الله برعايته ورزقك من ثمار الجنة ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 5.xlsb

وعليكم السلام ورحمة الله وبركانه وكل العام والجميع بخير لكافة اعضاء المنتدى اعتقد طلبك معادلة جزئيًا نعم، ولكن حذف الصف الأصلي تلقائيًا من شيت data → هذا غير ممكن بالمعادلات (حسب علمي والله اعلم ) اما عن طريق الكود فممكن الملف المرفق به كود يعمل تلقائيا كلما وجد كلمة معاش في شيت data في العمود H يقوم بترحيلها تلقائيا الى شيت معاشات مع حذفها من الشيت الاصلى وكذلك الترتيب التلقائي والتسلسل التلقائي في العمود A جرب تغيير تاريخ ميلاد اي اسم ليحال على المعاش ولاحظ عمل الكود ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات.xlsb

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

رداً للجميل في هذا المتدى المتميز، أرفق إليكم هذا الملف لإدارة الميزانية الشخصية، والذي استخدمت فيه دالة pivotable ودمجتها بدالة filter ، وتم عرض الملف بداش بورد جميل ومرتب.. تحياتي للجميع. الميزانية الشخصية.xlsm

أخي الكريم ، بداية تم اضافة حقل St_Sex في جدول الطلاب ،وتمتعيين القيمة للذكور والإناث ،وعليه جرب هذا الاستعلام :- SELECT St_Code & Switch( [StudyMaterialsEng]="ARABIC","ARA", [StudyMaterialsEng]="ART","ART", [StudyMaterialsEng]="ENGLISH","ENG", [StudyMaterialsEng]="MATH","MAT", [StudyMaterialsEng]="RELIGION","REL", [StudyMaterialsEng]="SCIENCE","SCI", [StudyMaterialsEng]="SOCIAL","SOC", [StudyMaterialsEng]="SPORT","SPO" ) AS Barcode, Query1.St_Code, Query1.St_Name, Query1.St_Group, Query1.StudyMaterialsEng, Query1.St_Sex FROM Query1 ORDER BY Switch( [StudyMaterialsEng]="ARABIC",1, [StudyMaterialsEng]="ART",2, [StudyMaterialsEng]="ENGLISH",3, [StudyMaterialsEng]="MATH",4, [StudyMaterialsEng]="RELIGION",5, [StudyMaterialsEng]="SCIENCE",6, [StudyMaterialsEng]="SOCIAL",7, [StudyMaterialsEng]="SPORT",8 ), [St_Group], Switch( InStr(1, [St_Sex], "ذكر") > 0, 1, InStr(1, [St_Sex], "أنثى") > 0, 2, True, 3 ), [St_Name]; الإستعلام Query5 هل يلبي مطلبك ؟؟ باركود نهائي.accdb

السلام عليكم حسب فهمى لطلبك وبدون ارفاق ملف منكم اليك الكود Sub RunMacroWithPassword() Dim password As String Dim userInput As String password = "1234" userInput = InputBox("من فضلك أدخل كلمة السر لتشغيل الماكرو:", "كلمة السر") If userInput = password Then MsgBox "كلمة السر صحيحة، سيتم الآن تشغيل الماكرو.", vbInformation Call MyProtectedMacro Else MsgBox "كلمة السر غير صحيحة. لن يتم تشغيل الماكرو.", vbCritical End If End Sub Sub MyProtectedMacro() MsgBox "تم تشغيل الماكرو بنجاح!", vbInformation ' أضف الكود الحقيقي هنا... End Sub الكود الاول Sub RunMacroWithPassword() وفيه المطالبة بكلمة السر وهي 1234 والكود الثاني Sub MyProtectedMacro() وهو الذي سيتم تنفيذه بعد وضع كلمة السر مثال تنفيذ ماكرو مع ادخال كلمة سر.xlsb

إصلاح مشكلة الإستيراد لأكثر من سجل من جوجل شيت . في الإصدار الأخير السابق وأتوجه بالشكر للأستاذ @Moosak للفته انتباهي لهذا الخلل . فقد تم بحمد الله تلافي وحل المشكلة من جذورها وإضافة ميزة جديدة وهي التعرف على طول القيمة التي سيتم استيرادها ( للحقول النصية ) . حيث طول الحقل النصي في اكسيس 255 حرف . وبهذا لا يمكن استيراد كامل القيمة اذا كانت أكبر من 255 حرف ، وسيتم ترك الفكرة للمستخدم بأن يكمل الإستيراد بعد ان يتم تقليص قيمة الخليه من جوجل شيت الى 255 أو الغاء العملية بالكامل .. وعليه ، فإن التعديل الجديد حل هذه المشكلة وغيرها .. ------------------------------ Excel Importor 2.0.zip ------------------------------

طب مبدئيا كل الشكر والتقدير لاساتذتنا العظماء استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل والاستاذ @Foksh ما قصور و وفوا وكفوا والله وبما أن الموضوع فى بدايته وقبل الابحار "روح" أي مشروع ناجح وضع الأساس السليم والذى يبدأ بالتحليل قبل التفكير فى الجدول ولكن الاهم كيف يمكن عمل تحليل النظم بأسس منهجيه صحيحة اولا وباختصار عند تصميم أى نظام: ابدأ بجمع كل المتطلبات بشكل كامل حدد الكيانات الأساسية وصفاتها أنشئ الجداول بشكل نظيف مع تحديد المفاتيح الأساسية اربط الجداول ببعضها عبر علاقات فعلية منظمة حافظ على مرونة الاستعلامات عبر بناء علاقات إضافية مؤقتة عند الحاجة سامع اللى بيقول هناك ايه الكلام ده ؟ ردا على هذا السؤال تفصيلا : كيف تقوم بعمل التحليل المناسب لمشروع قاعدة بيانات؟ 1. فهم متطلبات المشروع (Gather Requirements) اجمع كل التفاصيل من العميل أو من نفسك (لو بتعمل لنفسك). اسأل أسئلة مثل: ما هو الهدف الأساسي من القاعدة؟ ما هي أنواع المعلومات التي يجب تخزينها؟ ما العمليات التي يقوم بها المستخدمون؟ (إدخال، تعديل، بحث، تقارير، الخ) هل في صلاحيات مختلفة للمستخدمين؟ ما العمليات المستقبلية المحتملة؟ 2. تحديد الكيانات (Entities) الرئيسية الكيانات هي الأشياء أو الأشخاص أو الأحداث التي تحتاج إلى تسجيل بيانات عنها في مثال "شئون العاملين" الكيانات قد تكون: الموظف (Employee) الوظيفة (Job Title) القسم (Department) الإجازات (Vacations) المرتبات (Salaries) الحضور والانصراف (Attendance) التأمينات (Insurance) الجزاءات (Penalties) المكافآت (Rewards) 3. تعريف السمات (Attributes) لكل كيان لكل كيان تحدد المعلومات المرتبطة به مثلا للموظف (Employee): رقم الموظف الاسم تاريخ الميلاد العنوان رقم الهوية رقم الهاتف تاريخ التعيين الوظيفة الحالية المرتب الأساسي الحالة الاجتماعية .... الخ... 4. تحديد العلاقات بين الكيانات حدد كيف ترتبط الكيانات ببعضها مثال: كل موظف ينتمي إلى قسم واحد ⇚ علاقة واحد إلى متعدد (One-to-Many) كل موظف يمكن أن يكون له أكثر من إجازة ⇚ علاقة واحد إلى متعدد أيضا ¤ مهم جدا تحديد اتجاه العلاقة ونوعها كيف تحدد وضع التصور للجداول والهيكل؟ 1. تصميم الجداول بشكل طبيعي (Normalization) تأكد إن الجداول تكون بدون تكرار للمعلومات (تجنب تكرار نفس البيانات في أكثر من جدول) كل جدول يمثل كيان مستقل. 2. المفاتيح الأساسية (Primary Keys) كل جدول لازم يحتوي على مفتاح أساسي (Primary Key) يميز كل سجل بشكل فريد مثال: جدول الموظفين : الحقل EmployeeID \ مفتاح أساسي ولكن أنا لا احب و لا أفضل التعامل مع حقل الـ ID الافتراضى داخل الجداول الأفضل ترك حقل ID الذي ينشئه Access كمفتاح أساسي (AutoNumber) بدون تغيير حقل ID الأساسي يبقى دائما موجود داخل الجدول داخلي ما نلمسه وما نستعمله في الربط الخارجي فقط يحفظ سلامة السجلات داخليا إنشاء حقل يدوي خاص بك مثلا EmployeeID نوعه Number (Long Integer) / أو نص حسب الرغبة ضبط خاصية الفهرسة: "مفهرس بدون تكرار" عندما يكون نوعه أساسي (Primary ) أو "مفهرس يقبل التكرار" حسب نوعه أجنبي (Foreign Key) استخدام الحقل اليدوي (EmployeeID مثلا) للربط بين الجداول بدلا من ID هل عمل العلاقات مباشرة أم أثناء الاستعلامات؟ الأساس الدائم = العلاقات الفعلية في تصميم القاعدة الحالات الخاصة المؤقتة = علاقات مؤقتة داخل الاستعلامات ✍️ نصيحة ذهبية: دائما أنشئ المفتاح الأساسي بيدك سميه باسم يعبر عن الجدول خصائص فهرسته: فهرسة بدون تكرار كيف تسمي الحقول والمعرفات بطريقة صحيحة واحترافية؟ هذا رأيى الضئيل المتواضع وقد أكون مخطئ لانه سوف أختلف مع اساتذتى العظماء حتى لا تواجه مشاكل لاحقا مع الاستعلامات أو الربط أو حتى مع البرمجة اتبع القواعد دي: اسم المعرف = اسم الجدول بدون تكرار زائد + "ID" مثلاً: اسم الجدول اسم الحقل المفتاح الأساسي Employees EmployeeID Departments DepartmentID Vacations VacationID Salaries SalaryID قاعدة تسمية المفاتيح الأجنبية (Foreign Keys) لما تيجي تنقل مفتاح لجدول تاني (رابط)، خليه بنفس الاسم تمامًا! مثال: عندك جدول tblEmployees وفي جدول tblVacations بتربط الموظف اسم الحقل في Vacations هيكون أيضا : EmployeeID نفس الاسم بدون تغيير ليه؟ عشان لما تستخدم استعلامات فيها JOIN تربطهم بدون لخبطة أو إعادة تسمية أو لبس في فهم العلاقات خصائص الفهرسة لكل حالة الحالة الفهرسة في الجدول الأصلي (المفتاح الأساسي) مفهرس لا يقبل التكرار (Indexed - No Duplicates) في الجدول المرتبط (مفتاح أجنبي) مفهرس يقبل التكرار (Indexed - Duplicates OK) هل استخدام نفس الاسم (EmployeeID مثلا) يسبب مشكلة؟ لا طالما أنت ملتزم بالعلاقات الصحيحة (Relationships) واستخدمت أسماء الجداول والحروف الواضحة في الاستعلامات فلن تحدث مشكلة Access سوف يتعامل مع الحقول حسب السياق (اسم الجدول قبل الحقل لو حصل تعارض بسيط) ملاحظة إضافية تجنب الأسماء المحجوزة مثل (Name, Date, Year, User) لأنها قد تسبب مشاكل لاحقًا في الكود أو الاستعلامات حاول دائمًا تسمية الحقول بشكل يوحي بالمحتوى (BirthDate أفضل من Date فقط). ✍️ المختصر المفيد و الخلاصة : أنشئ أنت الحقول بنفسك = أفضل تحكم وجودة سم المفاتيح بشكل احترافي اسم الجدول + ID الفهرسة تكون حسب النوع: أساسي = بدون تكرار / أجنبي = يقبل التكرار لا تخف من تكرار اسم الحقل طالما هناك علاقة صحيحة مدعومة جيدا ..... يتبع

وعليكم السلام ورحمة الله وبركاته 🤗 .. تفضل البرنامج ، اضغط هنا .

وعليكم السلام ورحمة الله وبركاته تم تعديل المعادلات ليكون ارتباطها بالخلية N9 فقط في صفحة استدعاء ومن ضمنها الاعمدة المخفية D & K مع تعديل طفيف بالكود bac test1.xlsm

أقرت المملكة العربية السعودية منذ أيام قليلة رمزاً جديداً للريال السعودي، في هذا المقطع 3 طرق تشرح كتابة رمز الريال السعودي وإدراجه في برنامج اكسل، سواء إدراجه كصورة أو كحرف (رمز) من لوحة المفاتيح.

تفضل أخي الكريم حيث أن الملف مفيد للطلبة و ضمن المناهج الأكاديمية 2.xls

وعليكم السلام ورحمة الله وبركاته طلبك كبير ومهم جدًا لأي شخص يتعلم VBA في Excel. ارجو تحديد الاوامر المطلوب شرحها لان كل امر يحناج الى وقت لشرحه ويمكنك البحث في اليوتيوب تجد شروح عديدة ومفيدة في VBA – هناك فئات كثيرة من الأوامر: اهمها 🔹 1. التعامل مع الخلايا (Cells / Range) قراءة البيانات من خلايا متعددة - تغيير قيم مجموعة من الخلايا- التعامل مع نطاقات خلايا أكبر 🔹 2. التعامل مع الصفوف والأعمدة 🔹 3. التعامل مع الأوراق (Sheets) 🔹 4. التعامل مع المصنفات (Workbooks) 🔹 5. التعامل مع النصوص (Strings) 🔹 6. الرسائل (MsgBox و InputBox) إظهار رسالة تنبيه للمستخدم - استخدام InputBox للحصول على إدخال من المستخدم 🔹 7. التعامل مع البيانات (Data Manipulation) 🔹 8. التكرار (Loops) استخدام For Each للتكرار عبر مجموعة من الخلايا - استخدام حلقة For لتكرار الأوامر 🔹 9. المعاملات الشرطية (If و Select Case) استخدام If لتحديد شرط - استخدام Select Case بديلًا عن سلسلة If مع شروط متعددة 🔹 10. أوامر إيقاف الكود (Exit و End)

وعليكم السلام ورحمة الله وبركاته .. التنسيقات والمسافات خطوة يتبعها مبرمجوا وكاتبوا الأكواد لتتبع بداية ونهاية الأجزاء ، وخصوصاً الجمل والدوال والأكواد التي لها بداية ونهاية مثل الجمل الشرطية If أو Select .... الخ لذا فهي ليست ذات أي تأثير على سرعة أداء الكود أو عدم فعاليته . وجهة نظري البسيطة ، والله تعالى أعلم

وعليكم السلام ورحمة الله وبركاته جزاك الله خيرا على دعاؤك الطيب لي واسأل الله ان يجازيك خير الجزاء تم تعديل الكود ليتعامل مع البيانات الكثيرة بالنسبة للاحصائيات جعلتها في اعلى الصفحة والكود يقوم بحسابها آليا - ووجودها اسفل الصفحة يعرقل عمل الكود وحاولت ولم اتوصل الى نتيحة مرضية (حسب علمي ) بالنسبة للنرنيب التصاعدي الكود يتعامل مع العمود L في شيت معاشات وجربنه ويعمل جيدا الملف المرفق به 7000 تقريبا صف طبعا قم بنجربة الترحيل ولاحظ الترتيب واي ملاحظات اذكرها وات شاء الله وبعونه تقوم بالواجب لك كل التقدير والاحترام ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 3.xlsb

أشكرك أخي @kkhalifa1960 على الإلتفاتة الجميلة ، ولكن اسمح لي بمداخلة متفرعة . اذا كان طلب الأخ @حافظ التونسي هو وجود 0000 بعد رقم السنة ثم يبدأ الترقيم دون التأثير على الـ 0000 بحيث النتيجة تكون بهذا الشكل :- 202500001 ، 202500002 ، .... 2025000010 ، 2025000011 .... 2025000099999 = فإن اقتراحك جميل ويلبي الغرض . أما اذا كانت الفكرة كما تم تحديدها "رقم التسلسلي يتكون من رقم يحتوي على السنة الحالية و معها 5 ارقام ك 202500001" بحيث تكون بهذا الشكل :- 202500001 ، 202500002 ، 202500003 ، .... 202500010 ، 202500011 .... إلخ .... 202599999 = فأن التعديل الصحيح من جهتي سيكون للسطر الأخير بالشكل التالي :- GenerateID = CLng(yearPrefix & Format(serialPart + 1, "00000")) هنا سأضمن لك أن يكون الترقيم مكوناً من 5 خانات ، بوساطة دالة Format .. ويقبل التعديل حسب عدد الخانات التي يريدها صاحب الطلب بتغيير عدد الأصفار فقط . إلا أنني تجاهلت التقيد بعدد خانات محددة مثل ( 00000 ) . فنهاية الترقيم ستكون 202599999 . ولكن ماذا لو كان هناك سجل جديد وما زال العام 2025 لم ينتهي !؟!؟ لذا لم أقم بإضافتها أو التقيد بها أخي العزيز خليفة .

وعليكم السلام ورحمة الله وبركاته .. الأمر بسيط أخي الكريم إن شاء الله . اولاً سننشئ الدالة التالية في مديول :- Public Function GenerateID(TableName As String, fieldName As String) As Long Dim currentYear As Integer Dim yearPrefix As String Dim maxID As Long Dim serialPart As Long currentYear = Year(Date) yearPrefix = currentYear & "" maxID = Nz(DMax(fieldName, TableName, fieldName & " LIKE '" & yearPrefix & "*'"), yearPrefix & "00") serialPart = CLng(Mid(maxID, Len(yearPrefix) + 1)) GenerateID = CLng(yearPrefix & (serialPart + 1)) End Function ثم في مربع النص داخل النموذج سنقوم بجعل القيمة الإفتراضية لهذا المربع النصي = الإستدعاء التالي ( على اعتبار ان الجدةل اسمه Tbl_Cust والحقل الرقمي الخاص بالترقيم = ID ) .. =GenerateID("Tbl_Cust","ID") المرونة في الإستدعاء ستكون انه يمكنك استخدام الترقمي لأكثر من جدول . فقط بتغيير اسم الجدول وحقل الترقيم . وهذا مثال في ملف مرفق :- GenerateID.accdb

تفضل جرب هذا ورجاء ادخال مسارات الصورة فى العمود 10 فى شيت DbSheet او من خلال تحديد الاسم فى السجل داخل الليست بوكس وادخال الصورة المدرجة الخاصة بالموظف منظومة-الشؤون-الادارية - Copy - Copy.xlsm

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

تفضل جرب هدا لقد قمت بحدف مربعات النصوص الخاصة بعنوان المدرسة والسنة الدراسية وتعويضها بتنسيق الخلايا مباشرة يمكنك تعديلها بما يناسبك Option Explicit Const tmp As Long = 45 ' <======= ' إرتفاع صف إسم المدرسة Private Const CrWS As String = "النتيجة أ" Private Const sFolder As String = "نتائج التلاميد" ' <=======' إسم مجلد حفظ النتائج Private Const NamePDF As String = "النتائج" ' <=======' PDF إسم الملف المستخرج Private Const Password As String = "119900" ' <======= ' باسوورد الأوراق الخاص بك Sub Copy_SavePDF() On Error GoTo SupError Dim WS As Worksheet, f As Worksheet, Data As Worksheet, OnRng As Range, rng As Range, myRng As Range Dim sPath As String, tempFile As String, arr As Variant, r As Range, Cpt As Long Dim lastRow As Long, i As Long, j As Long, début As Integer, fin As Integer Set f = Sheets(CrWS): Set Data = Sheets("قوائم شهرية أ") If f Is Nothing Or Data Is Nothing Then Exit Sub SetApp False f.Unprotect Password: Data.Unprotect Password f.[A4].Value = 1 Set myRng = Data.Range("C7", Data.Range("C" & Data.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeFormulas, 2) f.[A3].Value = myRng.Cells(myRng.Rows.Count, 1).Offset(0, -2).Value début = f.[A4].Value: fin = f.[A3].Value If Not IsNumeric(f.[A4].Value) Or Not IsNumeric(f.[A3].Value) Or début < 1 Or fin < 1 Or début > fin Then GoTo EndSub If MsgBox("هل ترغب بحفظ النتائج من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then GoTo EndSub Set OnRng = f.Range("B7:P35") On Error Resume Next Set WS = Sheets("PDF") On Error GoTo SupError If WS Is Nothing Then Set WS = Sheets.Add: WS.Name = "PDF": WS.DisplayRightToLeft = True tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile For i = début To fin Step 2 f.[A4].Value = i lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B" & IIf(IsEmpty(WS.[B3].Value), lastRow + 1, lastRow + 5)) OnRng.Copy With rng .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths End With WS.HPageBreaks.Add Before:=WS.Cells(rng.Row + OnRng.Rows.Count, 1) Application.CutCopyMode = False Cpt = rng.Row Do While Cpt <= rng.Row + OnRng.Rows.Count - 1 If Not IsEmpty(WS.Cells(Cpt, 2).Value) Then WS.Rows(Cpt).rowHeight = tmp End If Cpt = Cpt + 15 Loop Next i lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set r = WS.Range("B1:P" & lastRow) arr = r.Value For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) If arr(i, j) = 0 Then arr(i, j) = "" Next j Next i r.Value = arr For i = 4 To lastRow If Trim(WS.Cells(i, 2).Value) = "اسم التلميذ/" And _ (WS.Cells(i, 14).Value = "" Or Not IsNumeric(WS.Cells(i, 14).Value)) Then WS.Rows(i).Hidden = True If i + 1 <= lastRow Then WS.Rows(i + 1).Hidden = True: If i - 1 >= 4 Then WS.Rows(i - 1).Hidden = True For j = i + 2 To lastRow WS.Rows(j).Hidden = True Next j Exit For End If Next i sPath = tempFile & "\" & NamePDF & ".pdf" With WS.PageSetup lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row .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) .CenterHorizontally = True: .PrintArea = "B1:P" & lastRow End With WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False f.[A4].Value = 1: WS.Delete MsgBox "تم حفظ جميع نتائج الطلاب بنجاح", vbInformation EndSub: f.Protect Password: Data.Protect Password SetApp True Exit Sub SupError: Resume EndSub End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next Application.ScreenUpdating = enable Application.EnableEvents = enable Application.DisplayAlerts = enable End Sub النتائج.pdf كنترول-صف-سادس-أ-ب سجل وسطي v2.xlsm

مشاركة مع اخي العزيز فادي واضافة الى ما افاد به وأجاد بعض الملاحظات البسيطة من واقع تجربة : ملاحظة فنية : - تسميات الحقول .. مثلا rkm_mlf في الجدول الرئيسي يجب ان يختلف في الجداول الأخرى اختلافا طفيفا اما بزيادة حرف او رقم .. وهذا ينطبق على جميع تسميات الحقول بين الجداول السبب في افضلية ايجاد فارق في التسمية هي احيانا تضطر الى ضم هذه الجداول في استعلام واحد .. حينها ستعرف فائدة التفرقة . ملاحظات في التصميم : تنقسم البيانات المتجددة الى نوعين .. 1- نوع يكون اصله في جدول الاسماء .. وما يستجد في جدول منفصل ، مع تحديث القيمة في جدول الاسماء عند كل حركة جديدة .. مثل الرتبة وترقياتها ، والوظيفة وتدرجاتها ، والنقل داخل المحافظة نفسها ( مكان العمل ) ، والمؤهل وتاريخه ونحو ذلك هذه الفكرة ستجد ثمرتها عظيمة مستقبلا عند البحث والتصفيات الجماعية وعمل التقارير .. ستكون سلسة وسريعة .. لان المصدر جدول واحد فقط التفاصيل الأخرى غالبا لن تحتاجها الا في الاستعلام عن موظف محدد بعينه 2- النوع الثاني الاصل يكون في جدول مستقل مثل الإجازات والتدريبات والجزاءات والعقوبات .. ونحو ذلك ------------------------------------- لا ننسى الجداول الخدمية وهي مهمة جدا مثل : جدول المؤهلات ، جدول الوظائف ... الخ وجميع الأشياء التي تتوقع البحث والاستعلام عنها يجب ان يكون لها جداول خدمية خاصة المهم يجب ان تعلم ان اي مشروع 80% منه هو اجادة وضبط الجداول فلا تخرج من الجداول ابدا حتى تتأكد انك استوفيت وأحكمت جميع اطراف مشروعك ناقش واعرض جداولك واستمر في المناقشة والاستفسار حتى تأخذ الضوء الاخضر من اخوانك هنا ..

هذه محاولتي 🙂 test (MoosaK).accdb

وعليكم السلام و رحمة الله و بركاته تفضل المطلوب في المرفق VV.accdb

يمكننا أخي تعديل الكود ليتناسب مع طلبك لاكن لاحظت انه هناك أسماء متشابهة الفرق الوحيد بينها هو المسافات كما في المثال الموضح في الصورة أسفله إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض Option Explicit Sub Extract_Names() Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean Dim Ons As Object, tbl As String, dict As Object, _ début As Long, lr As Long, tmp As Range, Key As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With AutoFilterWasOn = CrWS.AutoFilterMode If AutoFilterWasOn Then CrWS.AutoFilterMode = False lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _ CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare Set Ons = CreateObject("Scripting.Dictionary") Ons.CompareMode = vbTextCompare For Each tmp In CrWS.Range("B3:B" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row End If Next tmp CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents début = 3: dCount = 0: UniCount = 0 For Each tmp In CrWS.Range("A3:A" & lr) If Not IsEmpty(tmp.Value) Then tbl = Replace(Trim(tmp.Value), " ", "") If dict.exists(tbl) Then CrWS.Cells(début, 4).Value = tmp.Value CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1 End If End If Next tmp For Each Key In Ons.keys CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value début = début + 1: UniCount = UniCount + 1 Next Key CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount CrWS.Columns("D:E").AutoFit With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With End Sub Book2 v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Function NumtoTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim txtArr1(0 To 9) As String, txtArr2(0 To 9) As String, txtArr3(0 To 9) As String Dim Myno As String, GetNo As String, RdNo As String, My100 As String, I As Integer Dim My10 As String, My1 As String, My11 As String, My12 As String, GetTxt As String Dim MyAnd As String, Mybillion As String, MyMillion As String, MyThou As String Dim MyHun As String, MyFraction As String, ReMark As String If TheNo > 999999999999.999 Then Exit Function If TheNo < 0 Then TheNo = TheNo * -1: ReMark = "يتبقى لكم " Else ReMark = "" If TheNo = 0 Then NumtoTxt = "صفر": Exit Function MyAnd = " و" txtArr1(0) = "": txtArr1(1) = "مائة": txtArr1(2) = "مائتان": txtArr1(3) = "ثلاثمائة": txtArr1(4) = "أربعمائة" txtArr1(5) = "خمسمائة": txtArr1(6) = "ستمائة": txtArr1(7) = "سبعمائة": txtArr1(8) = "ثمانمائة": txtArr1(9) = "تسعمائة" txtArr2(0) = "": txtArr2(1) = "عشر": txtArr2(2) = "عشرون": txtArr2(3) = "ثلاثون": txtArr2(4) = "أربعون" txtArr2(5) = "خمسون": txtArr2(6) = "ستون": txtArr2(7) = "سبعون": txtArr2(8) = "ثمانون": txtArr2(9) = "تسعون" txtArr3(0) = "": txtArr3(1) = "واحد": txtArr3(2) = "اثنان": txtArr3(3) = "ثلاثة": txtArr3(4) = "أربعة" txtArr3(5) = "خمسة": txtArr3(6) = "ستة": txtArr3(7) = "سبعة": txtArr3(8) = "ثمانية": txtArr3(9) = "تسعة" GetNo = Format(TheNo, "000000000000.000") I = 0 Do While I < 15 If I < 12 Then Myno = Mid$(GetNo, I + 1, 3) ElseIf I = 12 Then Myno = Mid$(GetNo, I + 2, 3) End If If Val(Myno) > 0 Then RdNo = Mid$(Myno, 1, 1): My100 = txtArr1(Val(RdNo)) RdNo = Mid$(Myno, 3, 1): My1 = txtArr3(Val(RdNo)) RdNo = Mid$(Myno, 2, 1): My10 = txtArr2(Val(RdNo)) If Mid$(Myno, 2, 2) = "11" Then My11 = "إحدى عشر" If Mid$(Myno, 2, 2) = "12" Then My12 = "اثنا عشر" If Mid$(Myno, 2, 2) = "10" Then My10 = "عشرة" If Val(Mid$(Myno, 1, 1)) > 0 And Val(Mid$(Myno, 2, 2)) > 0 Then My100 = My100 + MyAnd If Val(Mid$(Myno, 3, 1)) > 0 And Val(Mid$(Myno, 2, 1)) > 1 Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If Val(Mid$(Myno, 3, 1)) = 1 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My11: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My11 End If If Val(Mid$(Myno, 3, 1)) = 2 And Val(Mid$(Myno, 2, 1)) = 1 Then GetTxt = My100 + My12: If Val(Mid$(Myno, 1, 1)) = 0 Then GetTxt = My12 End If If I = 0 And GetTxt <> "" Then If Val(Myno) > 10 Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If Val(Myno) = 1 Then Mybillion = "مليار" If Val(Myno) = 2 Then Mybillion = "ملياران" End If If I = 3 And GetTxt <> "" Then If Val(Myno) > 10 Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If Val(Myno) = 1 Then MyMillion = "مليون" If Val(Myno) = 2 Then MyMillion = "مليونان" End If If I = 6 And GetTxt <> "" Then If Val(Myno) > 10 Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If Val(Mid$(Myno, 3, 1)) = 1 Then MyThou = "ألف" If Val(Mid$(Myno, 3, 1)) = 2 Then MyThou = "ألفان" End If If I = 9 And GetTxt <> "" Then MyHun = GetTxt If I = 12 And GetTxt <> "" Then MyFraction = GetTxt End If I = I + 3 Loop If Mybillion <> "" Then If MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then Mybillion = Mybillion + MyAnd If MyMillion <> "" Then If MyThou <> "" Or MyHun <> "" Then MyMillion = MyMillion + MyAnd If MyThou <> "" Then If MyHun <> "" Then MyThou = MyThou + MyAnd If MyFraction <> "" Then If Mybillion <> "" Or MyMillion <> "" Or MyThou <> "" Or MyHun <> "" Then NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur & MyAnd & MyFraction & " " & MySubCur Else NumtoTxt = ReMark & MyFraction & " " & MySubCur End If Else NumtoTxt = ReMark & Mybillion & MyMillion & MyThou & MyHun & " " & MyCur End If End Function تعديل المبلغ - فلس V2.xlsm

طيب اليكم المرفق الاخيـــــــــــــــــــر المميزات : الاعتماد الكامل على الرقم القومى دوال منفصلة لسهولة استدعائها فى استعلام من خلال الرقم القومى يتم استخراج الجنس/النوع استخراج مكان الميلاد استخراج تاريخ الميلاد حساب العمر بالسنوات حساب العمر بالأشهر حساب العمر بالأيام بناء على حقل تاريخ الميلاد المستخرج من الرقم القومى يتم عمل التالى حساب تاريخ التقاعد حساب سن التقاعد السنوات المتبقيه للتقاعد الاشهر المتبقيه للتقاعد الايام المتبقيه للتقاعد افتح الاستعلام فى القاعده والذى يحمل الاسم : qryAllInfoFromNationalID المرونة المطلقه فقط عند نقل الوحدات النمطية الى اى قاعدة بيانات عمل استعلام وفقط تغير اسم الحقل الخاص بالرقم القومى تبعا للمسمى الموجود فى الجدول الخاص بكم والملون هنا باللون الاحمر BirthDateFromNationalID: GetBirthDateFromNationalID([Emp_NationalID]) وباقى حقول الاستعلام جميعا تعتمد على هذا الحقل لذلك يتم نقلها كما هى ولكن ولكن ولكن لا تغير اسم الحقل : BirthDateFromNationalID لان هذا الاسم تعتمد باقى وكل الحقول الاخرى عليه اعتقد بهذا المرفق يكون الموضوع قتل بحثا وتم عمل كل ما يمكن فيه ويمكن وبكل سهولة ومرونة الان استخدام الحقول المناسبه حسب الحاجه داخل التقارير او النماذج بكل بساطه تم اضافة : نموذج : frmAllInfoFromNationalID تقريــر : rptAllInfoFromNationalID مصدر بيانات كل منهما الاستعلام : qryAllInfoFromNationalID اما النموذج : frmEmployees مصدر بياناته هو الجدول مباشرة الان القاعده كاملة و متكاملة مع تحقيق أقصى درجات المرونه المطلقة والحصول على كل البيانات الممكنه من خلال الرقم القومى مباشره سن التقاعد (8).accdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اسم المستخدم : admin كلمة المرور : 1989 Option Compare Text Dim f, Rng, MH(), WS_Rng, DataRng Private Sub UserForm_Initialize() DataRng = "Tableau1" WS_Rng = Range(DataRng).Columns.Count MH = Range(DataRng).Resize(, WS_Rng + 1).Value For i = 1 To UBound(MH): MH(i, WS_Rng + 1) = i: Next i Me.ListBox1.List = MH Me.ListBox1.ColumnCount = WS_Rng + 1 Me.ListBox1.ColumnWidths = "70;110;100;100;100" Me.ComboBox1.List = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, 1)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Sht = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) For i = 1 To WS_Rng Me("label" & i) = Sht(i, 1) Next i For i = WS_Rng + 1 To 6 Me("label" & i).Visible = False: Me("TextBox" & i).Visible = False Next i Me.ComboBox2 = "*" T_resultat = "عدد الموظفين" & "/" & ListBox1.ListCount + 0 Count = ListBox1.ListCount End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Combobox1_click() Me.ListBox1.List = MH Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Me.T.Caption = "بحث ب:" & Me.ComboBox1 Set Titre = Range(DataRng).Offset(-1).Resize(1) colFiltre = Application.Match(Me.ComboBox1, Titre, 0) Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, colFiltre)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Me.ComboBox2 = Empty End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub TextBoxRech_Change() On Error Resume Next WSdest = Me.ComboBox1.ListIndex + 1 clé = "*" & Me.TextBoxRech & "*": n = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, WSdest) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To n) For k = 1 To UBound(MH, 2): Tbl(k, n) = MH(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.clear End Sub منظومة-الشؤون-الادارية.xlsm