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

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

مشاركة مع استاذى الجليل و معلمى القدير الاستاذ @ابو عارف وبعد إذن أستاذى هناك بعض الحالات التي قد تستوجب تعديلات إضافية لضمان التوافق بين الأنوية المختلفة (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

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

وعليكم السلام ورحمة الله وبركاته أخي @ابو نبأ الأمر بسيط جدا وسأشرح لك خطوة بخطوة كيف تضيف شرطا جديدا (مثل: موقع التحميل في العمود k) إلى الكود بحيث يمكنك لاحقا تعديل أو إضافة أي شرط بنفس الطريقة 1) التحقق من أن العمود الجديد (k) ليس فارغا If Trim(WS.Cells(i, "M").Text) <> "" And _ Trim(WS.Cells(i, "L").Text) <> "" And _ Trim(WS.Cells(i, "K").Text) <> "" And _ <===== (موقع التحميل) العمود الجديد 2) تعديل المفتاح M ليشمل القيمة الجديدة m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) 3) تعديل إخراج البيانات المفككة من المفتاح f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) 4) لا تنسى تعديل رؤوس الأعمدة في الصف الأول لتتناسب مع التغيير dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") ليكون الكود النهائي بعد إظافة عمود موقع التحميل على الشكل التالي Option Explicit Sub TEST2() Dim dest As Worksheet, WS As Worksheet Dim m As String, a As Variant, k As Variant, f As Variant Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ShArr As Variant: ShArr = Array("aaa", "bbb") Dim i As Long, lr As Long, r As Long: r = 2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual On Error Resume Next Set dest = Sheets("تقرير مفصل") If dest Is Nothing Then Set dest = Sheets.Add dest.Name = "تقرير مفصل" Else With dest.Range("A:G") .ClearContents .Borders.LineStyle = xlNone End With End If On Error GoTo 0 dest.Range("A1").Resize(1, 7).Value _ = Array("الشهر", "اسم الشركة", "الموقع", "عدد النقلات", "مجموع المبلغ للسائق", "مجموع مبلغ العقد", "مجموع الكمية (طن)") For Each WS In Sheets(ShArr) If WS.AutoFilterMode Then WS.AutoFilterMode = False lr = WS.Cells(WS.Rows.Count, "M").End(xlUp).Row For i = 2 To lr If Trim(WS.Cells(i, "M").Text) <> "" And Trim(WS.Cells(i, "L").Text) <> "" And Trim(WS.Cells(i, "K").Text) <> "" Then m = Trim(WS.Cells(i, "M").Text) & "|" & Trim(WS.Cells(i, "L").Text) & "|" & Trim(WS.Cells(i, "K").Text) If Not d.exists(m) Then d(m) = Array(0, 0, 0, 0) d(m) = Array(d(m)(0) + 1, d(m)(1) + tmp(WS.Cells(i, "S").Value), d(m)(2) + tmp(WS.Cells(i, "U").Value), d(m)(3) + tmp(WS.Cells(i, "F").Value)) End If Next i Next WS For Each k In d.Keys f = Split(k, "|") a = d(k) dest.Cells(r, 1).Resize(1, 7).Value = Array(f(0), f(1), f(2), a(0), a(1), a(2), a(3)) r = r + 1 Next k Call ShFormat(dest, "A:G") .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم إعداد التقرير المفصل بنجاح", vbInformation End Sub "======================================= Private Function tmp(x As Variant) As Double tmp = IIf(IsNumeric(x), x, 0) End Function '======================================= Private Sub ShFormat(ByRef WS As Worksheet, ByVal Col As String) With WS .Activate Dim lastRow As Long lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row With WS.Range("A1:G" & lastRow).Borders .LineStyle = xlDash: .Weight = xlThin: .ColorIndex = xlAutomatic End With .DisplayRightToLeft = True .Columns(Col).EntireColumn.AutoFit .Columns(Col).HorizontalAlignment = xlCenter .Columns(Col).VerticalAlignment = xlBottom .Range("E:G").NumberFormat = "0" End With End Sub ملاحظة : يمكنك تعطيل تنسيق الجدول النهائي بحذف أو تعليق هذا السطر أو تعديله ليشمل أعمدة أكثر إذا زادت الأعمدة لاحقا Call ShFormat(dest, "A:G") تقرير - حسب - الشهر - والشركة -الموقعV2 .xlsm

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

السلام عليكم ورحمة الله وبركاته جرب التعديل التالي جدول التفريغ V2 (1).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ضع هدا في حدث ورقة معلمين Option Explicit Private Const ShName As String = "معلمين" Private Sub Worksheet_Calculate() Static tmps As Boolean If tmps Then Exit Sub tmps = True If Not IsEmpty(Me.Range("D5").Value) Then Coloring_Classes tmps = False End Sub Sub Coloring_Classes() Dim Sh As Worksheet: Set Sh = ThisWorkbook.Sheets(ShName) On Error GoTo HandleError Application.ScreenUpdating = False: Application.EnableEvents = False Application.Calculation = xlCalculationManual xColor Sh, Sh.[D5].Value, "C7:I11" xColor Sh, Sh.[D18].Value, "C20:I24" xColor Sh, Sh.[D30].Value, "C32:I36" Cleanup: Application.ScreenUpdating = True: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Exit Sub HandleError: Resume Cleanup End Sub Sub xColor(ws As Worksheet, Search As String, cnt As String) Dim xCell As Range, xRng As Long, OnRng As Range, ky As Variant Dim r As Long, c As Long, n() As Long Set OnRng = ws.Range(cnt) If Trim(Search) = "" Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub Set xCell = ws.Range("Q2:Q" & ws.Cells(ws.Rows.Count, "Q").End(xlUp).Row) _ .Find(What:=Search, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) If xCell Is Nothing Then: OnRng.Interior.ColorIndex = xlColorIndexNone: Exit Sub xRng = xCell.Offset(0, 1).Interior.Color ky = OnRng.Value ReDim n(1 To UBound(ky, 1), 1 To UBound(ky, 2)) For r = 1 To UBound(ky, 1) For c = 1 To UBound(ky, 2) If Not IsError(ky(r, c)) And Len(Trim(ky(r, c))) > 0 Then n(r, c) = xRng End If Next c Next r OnRng.Interior.ColorIndex = xlColorIndexNone For r = 1 To UBound(n, 1) For c = 1 To UBound(n, 2) If n(r, c) <> 0 Then OnRng.Cells(r, c).Interior.Color = n(r, c) End If Next c Next r End Sub جدول التفريغ V2.xlsm

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

السلام عليكم ورحمة الله وبركاته بعد اذن معلمنا واستاذنا محمد هشام جدول2.xlsm

السلام عليكم حسب فهمى لطلبك وبدون ارفاق ملف منكم اليك الكود 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

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تنفيذ ذلك باستخدام الأكواد ولكن أعتقد أنه سيكون من الضروري أولا تنظيم البيانات في ورقة العمل 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

نعم أخي @نبا زيد يمكننا فعل دالك لاكن لدي إقتراح أعتقد أنه أفضل بدلا من تعديل الألوان مباشرة في الكود كل مرة يمكنك تحديد ألوان الخلفية ولون الخط بسهولة من داخل ورقة تمت إظافتها للملف بإسم الإعدادات كما هو موضح في الصورة التالية كل ما عليك فعله هو 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

إدن لنجرب هدا 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

عدل هنا تنسيق التاريخ بما يناسبك 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

اخي ريان نحاول المساعدة ولكنك لم تكلف نفسك بادراج ملف PDF الموجود لديك لنرى التصميم لديك ولا قاعدة بياناتك ( انت ادرجت لنا مرة اخرى قاعدة بيانات الاستاذ @kkhalifa1960 لنقل بيانات من الاكسس الى PDF : اولا يجب ان يكون لديك برنامج برنامج Adobe Acrobat Pro (وليس Adobe Reader فقط) او برنامج PDFtk ثانيا ملف PDF يجب ان يكون استمارة فردية اي لعرض بيانات فردية وليس نموذج مستمر كما ارفقت انت في مثال اخونا خليفة ثالثا تفعيل المرجع Adobe Acrobat xx.x Type Library (xx = رقم الإصدار مثل 10.0 أو 11.0) رابعا يجب أن يحتوي ملف الـ PDF على الحقول المسماة مثلا : وهذه يم اضافتها عن طريق البرامج المذكورة في اولا "Text1" "Dropdown2" "todaysDate" خامسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم PDFtk ::::::::::::::::::::::::: Sub FillPDF() Dim tempFDF As String Dim pdfInput As String Dim pdfOutput As String Dim shellCmd As String Dim fso As Object Dim fdfContent As String Dim pdftkPath As String Dim appPath As String ' تحديد مسار البرنامج الحالي (نفس مجلد قاعدة البيانات أو ملف الإكسل) appPath = Application.CurrentProject.Path ' Access ' إذا كنت تستخدم Excel بدلاً من Access، استبدل بالسطر التالي: ' appPath = ThisWorkbook.Path ' تحديد مسار الملفات pdfInput = appPath & "\template.pdf" ' اسم ملف PDF بجانب الملف pdfOutput = appPath & "\output_filled.pdf" ' ملف الإخراج بجانب الملف tempFDF = appPath & "\temp_data.fdf" ' ملف FDF مؤقت ' مسار برنامج PDFtk pdftkPath = """C:\Program Files (x86)\PDFtk Server\bin\pdftk.exe""" ' تحضير محتوى FDF fdfContent = "%FDF-1.2" & vbCrLf fdfContent = fdfContent & "1 0 obj<</FDF<< /Fields[" & _ "<< /T (Text1) /V (" & Me.Text0.Value & ") >>" & _ "<< /T (Dropdown2) /V (" & Me.Text2.Value & ") >>" & _ "<< /T (todaysDate) /V (" & Me.Text4.Value & ") >>" & _ "] >> >>endobj" & vbCrLf fdfContent = fdfContent & "trailer<</Root 1 0 R>>" & vbCrLf fdfContent = fdfContent & "%%EOF" ' إنشاء ملف FDF Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(tempFDF, True) .Write fdfContent .Close End With ' تنفيذ الأمر باستخدام PDFtk shellCmd = pdftkPath & " """ & pdfInput & """ fill_form """ & tempFDF & """ output """ & pdfOutput & """ flatten" Shell shellCmd, vbHide MsgBox "تم إنشاء الملف: " & pdfOutput End Sub سادسا استخدام هذه الشيفرة اذا كان البرنامج المستخدم Adobe Acrobat Pro ::::::::::::::::::::::::: Dim AcroApp As Acrobat.CAcroApp Dim theForm As Acrobat.CAcroPDDoc Dim jso As Object Dim path As String Dim field As Object Dim Text1, Dropdown2, todaysDate As String Dim Text0, Text2, Text4 As String Set AcroApp = CreateObject("AcroExch.App") Set theForm = CreateObject("AcroExch.PDDoc") theForm.Open (Me.Label16.Caption) Set jso = theForm.GetJSObject 'write the values to corresponding pdf fields jso.getfield("Text1").Value = Me.Text0.Value jso.getfield("Dropdown2").Value = Me.Text2.Value jso.getfield("todaysDate").Value = Me.Text4.Value theForm.Save PDSaveIncremental, Me.Label16.Caption theForm.Close AcroApp.Exit Set AcroApp = Nothing Set theForm = Nothing سابعا ::: انا دوري انتهى هنا بارك الله فيك

Try #If VBA7 Then Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr #Else Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long #End If Function CreateElevatedFile(ByVal sFilePath As String, ByVal sFileContent As String) As Boolean On Error GoTo ErrorHandler Dim fso As Object, sScriptPath As String, psScript As String, EscFilePath As String, EscContent As String sScriptPath = Environ("TEMP") & "\create_elevated_file.ps1" EscFilePath = Replace(Replace(sFilePath, "'", "''"), """", "\""") EscContent = Replace(Replace(sFileContent, "'", "''"), """", "\""") psScript = "$t = [System.Diagnostics.ProcessWindowStyle]::Hidden;$p = Start-Process -WindowStyle $t -FilePath 'powershell.exe' -ArgumentList '-Command ""Set-Content -Path \""" & EscFilePath & "\""` -Value \""" & EscContent & "\""""' -Verb RunAs -PassThru;$p.WaitForExit();Exit $p.ExitCode" Set fso = CreateObject("Scripting.FileSystemObject") With fso.CreateTextFile(sScriptPath, True) .WriteLine psScript .Close End With ShellExecute 0, "runas", "powershell.exe", "-ExecutionPolicy Bypass -WindowStyle Hidden -File """ & sScriptPath & """", vbNullString, 0 CreateElevatedFile = True Exit Function ErrorHandler: CreateElevatedFile = False End Function Sub Create_File_With_Elevated_Permissions() Dim success As Boolean success = CreateElevatedFile("C:\Windows\Test.txt", "This Was Created With Elevated Permissions") If success Then MsgBox "File Created Successfully", vbInformation Else MsgBox "File Not Created", vbExclamation End If End Sub

إثراءا للموضوع يمكنك توسيع منع التكرار على عدة أعمدة مثلا A - C - E Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, OnRng As Range, Cell As Range Dim ColArr As Variant, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False ColArr = Array("A", "C", "E") ' ColArr = Array("A") For i = LBound(ColArr) To UBound(ColArr) If Not Intersect(Target, Me.Range(ColArr(i) & "2:" & ColArr(i) & Me.Rows.Count)) Is Nothing Then Set OnRng = Me.Columns(ColArr(i)) For Each Cell In Intersect(Target, OnRng) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(OnRng, Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If Next i CleanExit: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب الملف يتم الحدف عند الادخال او عند اللصق Private Sub Worksheet_Change(ByVal Target As Range) Dim rngChanged As Range Dim cell As Range Dim dict As Object Dim lastRow As Long Dim ws As Worksheet Set ws = Me lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rngChanged = Intersect(Target, ws.Range("A1:A" & lastRow)) If rngChanged Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In ws.Range("A1:A" & lastRow) If Not Intersect(cell, rngChanged) Is Nothing Then GoTo NextCell If Not IsEmpty(cell.Value) Then dict.Add CStr(cell.Value), 1 End If NextCell: Next cell For Each cell In rngChanged If Not IsEmpty(cell.Value) Then If dict.exists(CStr(cell.Value)) Then Application.Undo ' MsgBox "القيمة '" & cell.Value & "' موجودة مسبقاً!", vbExclamation, "تنبيه" Exit For Else dict.Add CStr(cell.Value), 1 End If End If Next cell Application.EnableEvents = True Application.ScreenUpdating = True End Sub no duplicate.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل ترغب بإستخدام الأكواد ؟ ادا كان هدا يناسبك ضع هدا في حدث الورقة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range, tmp As Long On Error GoTo CleanExit Application.EnableEvents = False If Not Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) Is Nothing Then For Each Cell In Intersect(Target, Me.Range("A2:A" & Me.Rows.Count)) If Trim(Cell.Value) <> "" Then tmp = Application.WorksheetFunction.CountIf(Me.Range("A:A"), Cell.Value) If tmp > 1 Then Cell.ClearContents End If End If Next Cell End If CleanExit: Application.EnableEvents = True End Sub

رائع كود الاستاذ/ عبدالله حل آخر بالمعادلات و التنسيق الشرطي بعيدا عن الأكواد Book5.xlsx

وعليكم السلام ورحمة الله وبركاته حسب قهمي لطلبك اليك الملف في حالة تساوي القيم الاعلى يتم دكرها مع تظليل الصف Book4.xlsb

تفضل حدول 2.xlsm

و عليكم السلام ورحمة الله و بركاته يمكن استخدام المعادلة التالية =IF(A2="زمنية"; IF(D2<C2; IF(D2>=12; (D2-C2); (D2+12-C2)); IF(AND(C2>=12; D2>=12); (D2-C2); IF(C2>=12; (D2+12-C2); (D2-C2)) ) ) + IF(B2<>OFFSET(B2;1;0); 24*(OFFSET(B2;1;0)-B2); 0); "") معادلة لاحتساب من وقت الخروج والدخول (2).xlsx

السلام عليكم عاااااش والله لم يخطر على بالى ان ممكن نرجع الهيلوغريفى ده لعربى وكمان لم يخطر على بالى ابحث عن حل هذه المشكلة الله عليك عاش بجد شوف يا استاذنا الغالى انت لازم تعمل لعنصر التحكم اللى هيتم اللصق له او النسخ منه : 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

وعليكم السلام ورحمة الله وبركانه الكود يقوم بفرز الاسماء المكررة ويضعها في العمود 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

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

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

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

أولًا: أهداف النظام تنظيم عمليات تسجيل اليوميات بجميع أنواعها (اعتيادية - عارضة - بدل ساعات - بدل مبيت – تصريح تأخير – تصريح إنصراف مبكر - .... الخ ). ضمان الالتزام بالسياسات المعتمدة للموارد البشرية و اللوائح المنظمة. تسهيل الرقابة الداخلية عبر ربط قواعد لوائح العمل و تالحقق منها و قبل التسجيل الفوري لأنواع اليوميات التى تخص الأجازات. ثانيًا: قواعد الأجازات العامة ضرورة إدخال كافة البيانات المطلوبة (كود الموظف - نوع الأجازة - تاريخ البداية والنهاية). التحقق من صلاحية التواريخ وإدخالها بالشكل الصحيح. يتم التحقق من وجود يوميات سابقة فى نفس التاريخ لتفادي التعارض أو التكرار. ثالثًا: القواعد الخاصة بالأجازة العارضة أقصى مدة للأجازة العارضة : يومان عمل متتاليان فقط. ممنوع أن تتخلل الأجازة العارضة عطلات رسمية أو أسبوعية. يمنع تسجيل أجازة عارضة بعد أو قبل أجازة اعتيادية سواء مباشرة أو غير مباشرة حتى لو بينهما عطلات ( أسبوعية / رسمية ). ممنوع تسجيل أجازة عارضة تالية مباشرةً لإجازة عارضة سابقة مدتها يومان، لتفادي أجازات مطولة غير مسموحة حتى لا تتعدى اليومان. يخضع الحد السنوي للأجازات الاعتيادية أو العارضة لسياسات الموارد البشرية المعتمدة. رابعًا: القواعد الخاصة بالأجازات الأخرى الأجازة الاعتيادية تخضع للسياسات العامة دون حدود لعدد الأيام المتتالية بشرط اعتماد التوافر في الرصيد. رقم مسلسل خاص بكل أجازة اعتيادية لعمل حصر عدد ألايام المتصلة أى التى تتاببع فى التاريخ ولكن يتخللها عطلات. أجازات بدل الساعات وبدل المبيت يتم التحقق من أحقيتها بناءً على النوع المختار يمكن فقط لبدل الساعات والبدل مبيت أن يكون تاريخ بدء الأجازة أكبر من أو أصغر من تاريخ النهاية على يكون تاريخ نهاية الاجازة هو يوم البدل والذى قد يكون يوم عطلة أو يوم عمل عادى. أى نوع أخر من الأجازات أو اليوميات لابد وأن يكون تاريخ البدء أصغر من تاريخ الإنتهاء. السؤال هو : كيف يمكن تحقيق ذلك ؟! أم هو صعب مرفق صغير يحتوى على الجداول الاساسية حتى يتم أخذ النقاط التالية فى الحسبان عند بناء قاعدة البيانات و العمل عليها جدول يحدد تواريخ العطلات الرسمية "tblHolidaysOfficial". جدول يحدد أسماء أيام العطلات الأسبوعية "tblHolidaysWeekly". جدول يحدد انواع اليوميات "tblDailyType". بالنسبه لجدول " tblDailyType" يحتوى على الحقل : IsRecordMultiple بوليانى ليدل على أن اليومية تستوجب أن يتم تسجيلها فى سجل واحد فقط فردى أى لتاريخ واحد فقط أم لعدة تواريخ على عدة سجلات. وأخير الجدول المطلوب تسجيل اليوميات بداخله "tblDailyRecords". توضيح مطلوب عند إدخال أو تحديد تاريخ البدء وتاريخ الإنتهاء يتم التسجيل للبيانات داخل جدول "tblDailyRecords" على أن يكون سجل لكل تاريخ بداية من تاريخ البدء وحتى تاريخ الانتهاء. و طبعا الشروط اللى انا كتبتها تخص لائحة قانونيه حسب قانون العمل المصرى لا اعرف قد يختلف من بلد لأخر ولكن على الأقل ما أعرفه لإضفاء المرونة و عدم التقيد بإستخدام أسماء العطلات الرسمية بشكل مباشر من الكود لذلك طلبت أن يتم الإعتماد على الجدول "tblHolidaysWeekly". و إن أمكن تحقيق ذلك هل يمكن أن أرى طرح أساتذتى و أخوانى الكرام هذا الجزء و بدون منازع هو ثلث إدارة الموارد البشرية للعاملن داخل أى مؤسسة بدون مبالغة و هو صعب مش سهل لان ممكن يتم تسجيل اجازة فى يوم أو فى جلسة عمل و بعد حفظ السجل أو اغلاق وإعادة فتح القاعدة يتم عمل إمتداد لنفس نوع الأجازة و هنا هو التحدى الحقيقى و بوجه خاص مع النوعين ( أجازة إعتيادية / أجازة عارضة ) بسبب اللوائح التى تم ذكرها سابقا فى القواعد السابقة و مرة أخرى لابد من عمل حصر لعدد الاجازات الاعتيادية لكل موظف و التى تساوي أو تتعدي عدد 6 أيام متصلين أى يتخللهم عطلات ( أسبوعيه / رسمية ) و التى قد يتم تسجيلها على أكثر من جلسة عمل أو جلستين عمل أو حتى 6 جلسات عمل وهنا تحدى آخر أه علشان محدش يقول داخل يشغلنا أو داخل يستظرف وبيطلب طلب كبير أو ضخم لأنه متشعب جدا وقد يكون معقد أو هو مش عارف يعنى يعمل اللى بيقوله ده أنا تقريبا بفضل الله تعالى انتهيت من كل ده وفى حيز التجربــة ولكن الموضوع كان تحدى وكان مبنى على أفكارى الضئيلة و المتواضعة وطبعا لأن أفكارى دائما قد تكون معقدة أو لأنه أنا مجرد هاو لذلك أريد أن أرى أفكاركم و أطروحاتكم نظريا و عمليا و مناقشة عندما تستدعى الحاجة إما لأعدل أفكارى أو أكمل ما ينقصنى لا تعنى كلمة تحدى التى استخدمها هو التنافس او تحدى الاشخاص فمن أنا لأتحدث مستخدما هذه العبارات بمعناها الحرفى مع أساتذتى العظماء و أخوانى الكرام ولكن أقصد التحدى فى ترتيب الإفكار والخطوات وتطبيق القيود والتحققات داخل الكود واثناء التسجيل سواء كان التسجيل لليومية فى جلسه عمل واحده أو مع عدة جلسات عمل لنفس نوع اليومية أو أنواع اليوميات التى لها تحققات خاصة لنفس الموظف وأخيرا دمتم بكل حب و طيبتم وبيض الله وجوهكم شروط وقيود لائحة الأجازات.accdb

الفصل الثالث CH3.docx

أخي الكريم ، بداية تم اضافة حقل 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

اعرض الملف مستورد السجلات الذكي 2025 السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكن بطريقة ونكهة مختلفتين ▫▪◽◾◻◼. "أداة مستورد السجلات الذكي من Excel" ، أداة مبتكرة تتيح لك استيراد البيانات من ملفات Excel إلى قواعد بيانات Access بكل مرونة وسرعة . يتميز هذا البرنامج أو الأداة بواجهة بسيطة وميزات قوية تجعل التعامل مع البيانات تجربة مريحة ، حتى للمستخدمين الذين ليست لديهم خبرة تقنية كبيرة في التعامل مع هذا النوع من المتطلبات . فالكثير من الأشخاص في منتدانا هنا سأل عن إمكانية استيراد بيانات من اكسل من حقل محدد أو بطرق محددة ( تناسب إحتياجاته ) ، ولهذا كانت الفكرة هذه تنفيذاً لمتطلباتهم .. 🎯 سنستعرض أهم ميزات هذا البرنامج وكيف يمكن أن يسهم في تحسين إنتاجيتك وتوفير وقتك . تابع القراءة لاكتشاف كيف يمكنك الاستفادة من هذا الحل الذكي لإدارة البيانات 😇 . ميزات برنامج مستورد السجلات الذكي من Excel 📂 التكامل مع Excel يمكن اختيار ملفات Excel بسهولة باستخدام نافذة اختيار الملفات . يدعم البرنامج ملفات بصيغة xls / xlsx ، وغيرها . دعم كامل للإستيراد من جوجل شيت Google Sheets . 📋 التعامل مع الأوراق والبيانات عرض جميع أوراق العمل (Sheets) الموجودة في ملف Excel المحدد ، أو رابط جوجل شيت . عرض أسماء الأعمدة في الورقة المحددة لتسهيل تحديد العمود / الأعمدة المستهدفة . 🚀 الاستيراد المرن للبيانات استيراد بيانات من عمود محدد أو عدة أعمدة من ملف Excel أو جوجل شيت بناءً على اختيار المستخدم . تحديد الصفوف التي تبدأ منها عملية الاستيراد (لتجاوز رؤوس الأعمدة إن وجدت 👌 ) . 🗂️ الإدارة المتقدمة للبيانات داخل Access استيراد البيانات إلى جدول محدد داخل قاعدة البيانات الحالية . دعم لتحديد الحقول الهدف داخل الجدول . إمكانية تفعيل خاصية الترقيم التلقائي لإضافة قيم تسلسلية إلى الحقول المخصصة ( باستخدام الدالة DMAX ) . التعرف الكامل في جوجل شيت على توافق أنوع الحقول مع الحقول في الجدول المستهدف . التعرف على عدد الحروف إن كان اكبر من 255 حرف في الحقول ذات النوع " نص قصير " ⚡ أداء عالي مع دفعات من البيانات تقسيم البيانات إلى دفعات عند استيراد كميات كبيرة لتجنب مشاكل الأداء . إدارة مرنة لعدد السجلات التي يتم استيرادها في كل دفعة . 🎨 واجهة مستخدم ديناميكية إظهار أو إخفاء المساعدة البصرية بضغطة زر . تحديث الكومبوبوكس بطريقة ديناميكيًا بناءً على اختيارات المستخدم . في القسم الخاص بجوجل شيت ، تم إضافة مساعد لخطوات إنشاء API سليم وموضح في الفيديو المرفق . 🔒 إجراءات أمان واسترجاع دعم لاسترجاع البيانات عند حدوث خطأ أثناء عملية الاستيراد ( Rollback ) . التنبيه برسائل خطأ واضحة إذا لم يتم اختيار الملف أو إعداد الخيارات بشكل صحيح . 🧹 إدارة الموارد تنظيف جميع الموارد المفتوحة (ملفات Excel أو الاتصال بالبيانات) عند إغلاق النموذج . منع أي تأثير سلبي على النظام عند حدوث خطأ . ✨ سهولة الاستخدام تصميم بسيط يعرض التعليمات ويطلب إدخال البيانات الضرورية فقط . رسائل توجيهية للمستخدم لتحسين تجربة الاستخدام . ⚙️ المرونة في تخصيص الخيارات خيارات لتحديث السجلات الموجودة أو إضافة سجلات جديدة . دعم مجموعات البيانات المختلفة من خلال تحديد طريقة المعالجة . دعم ملف اكسيل مرفوع برابط مباشر في جوجل درايف - يتم تحويله الى جوجل شيت . في الجزء الخاص بالتعامل مع جوجل شيت :- فقط اختر الرابط ( نسخ ولصق ) وادخاله في رسالة رابط الملف كما في الصورة التالية :- الأداة تدعم استكمال الجلسة لآخر رابط تم استخدامه ( توفيراً للوقت واختصاراً لفكرة استخدام الرابط نفسه في كل مرة ) ، بحيث تظهر لك رسالة كالآتي :- حيث اذا كان اختيارك لـ Yes يتم التعرف على آخر رابط تم استخدامه ( حتى بعد اغلاق الأداة ) ، وإذا كان رد المستخدم No يتم اظهار رسالة ادخال رابط جديد ( ويتم اعتماده للجلسة اللاحقة ) .. الأداة تحتوي على معالج مساعد لمساعدة المستخدم ( أول مرة فقط ) على انشاء حساب في جوجل درايف وكيفية التعامل مع الـ API الخاصة بـ Google Sheets لتهيئة الأداة للتعامل مع روابط جوجل شيت لاستيراد السجلات منه . في التحديث الجديد للأداة ، يتم التعرف على الأخطاء التي يمكن حصولها أثناء اختيار حقل وخلية لا يوجد بينهما توافق في نوع البيانات ، فمثلاً لو تم اختيار خليه تحتوي على تاريخ ويقابلها حقل في الجدول ( في آكسيس ) من نوع رقمي مثلاً ، فإن الاداة تخبرك بنوع الحقل والتصحيح الذي يمكن تعديله .. واجهة الأداة :- * صورة من الواجهة الخاصة بـ Google Sheets . يلزم إضافة مكتبة Microsoft Office xx.0 Object Library فقط .. ⭐على سبيل المثال ، لدينا جدول اكسل يحتوي على عدد سجلات يتكون من أعمدة على سبيل المثال ( اسم الموظف ، رقم الموظق ، رقم الهاتف ، الجنسية ) وعدد السجلات = 50 صف مثلاً . وفي جدول اكسيس لدينا جدول الموظفين ونريد استيراد عدد سجلات محدد من نطاق محدد من ملف اكسل أو جوجل شيت ، و من عمود محدد أو عدة أعمدة ؛ لذا بعد اختيار ملف الاكسل أو رابط ملف جوجل شيت ، سيتم :- أولاً جلب أسماء الأوراق التي يتكون منها الملف . ثانياً جلب أسماء الأعمدة التي تتكون منها الورقة التي تم اختيارها ( اسم الموظف ، رقم الموظق ، رقم الهاتف ، الجنسية ) . ونختار على سبيل المثال اسم الموظف . ثم نحدد رقم الصف الذي تبدأ به البيانات التي نريدها ، ولنفترض ان الخليه A1 تحتوي عناوين الأعمدة كما ذكرنا سابقاً ؛ وعليه فإن البيانات ستبدأ من الخلية A2 ( على العتبار ان اسم الموظف في العمود A ) في ملف اكسل . ثالثاً نحدد الجدول الذي نريد جلب واستيراد البيانات اليه ، ثم نحدد الحقل الهدف الذي سيتم نقل ابيانات اليه . رابعاً حدد عدد السجلات التي تريد جلبها ، ولنفترض أننا نريد جلب القيم الـ 5 من الخليه A2 - A6 . وإذا أردنا جلب جميع السجلات ( الـ 50 كما ذكرنا في مثالنا ) نترك القيمة في عدد السجلات المستوردة = 0 . خامساً نحدد نوع الحدث ( تحديث - إضافة ) . فماذا يعني تحديث أو إضافة ؟ تحديث : سيتم تحديث الحقل المستهدف من أول قيمة وحتى العدد المحدد في عدد السجلات المستوردة . وعليه فإن القيم السابقة للحقل سيتم استبدالها بالقيم الجديدة . إضافة : سيتم إضافة سجلات جديدة للجدول المستهدف بغض النظر عن السجلات السابقة ولن تتأثر البيانات القديمة عند الإضافة . الآن كنقطة مهمة يجب التنويه لها في هذا البرنامج ، وهي لنفترض انك استوردت عدد سجلات = 5 كما قلنا سابقاً من حقل اسم الموظف . وأردت استيراد عدد 10 سجلات من حقل رقم الهاتف ( نوع احركة تحديث ) هنا سيتم تحديث عدد السجلات الحالي في الجدول بالقيم الـ 5 الأولى ، ثم سيتم إضافة باقي القيم ( الـ 5 سجلات ) وكأنها سجلات جديدة . أي أنها حركة تحديث وحركة إضافة للقيم التي ليس لها سجلات . سادساً وهي نقطة الترقيم . اعتمدت في البرنامج على الدالة DMAX بالترقيم . بحيث يتم اضافة 1 الى أكبر قيمة في الجدول بعد تحديد حقل الترقيم ( رقم الموظف مثلاً ) . أما اذا كان لديك حقل ترقيم تلقائي في الجدول فلا يستلزم على المستخدم تفعيل هذه الميزة . سابعاً يجب على المستخدم الإلتزام بضرورة توخي الحذر عند اختيار الحقول بحيث ينتبه لنوع الحقل . فمثلاً لن يتم اضافة قيم نصية مثل اسم الموظف من اكسل الى حقل رقم الموظف ( حقل رقمي ) . وهذه النقطة لا شك فيها !! صاحب الملف Foksh تمت الاضافه 04/21/25 الاقسام قسم الأكسيس  

طب مبدئيا كل الشكر والتقدير لاساتذتنا العظماء استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل والاستاذ @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 الفهرسة تكون حسب النوع: أساسي = بدون تكرار / أجنبي = يقبل التكرار لا تخف من تكرار اسم الحقل طالما هناك علاقة صحيحة مدعومة جيدا ..... يتبع

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

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

كلمة شكر لا تكفي بداية كل الشكر والعرفان بالجميل لكل القائمين على (أوفيسنا Excel) ذلك الصرح التعليمي الرائع الذي نتعلم منه ونلجأ إليه دوما عندما نجهل معلومة ما فنجد كل الدعم والمساعدة المجردة من أية أهواء أو أغراض والشكر موصول لجميع من ينتمي لهذا المنتدى التعليمي الخالص لوجه الله تعالى؛ وفي هذا المقام أحب أن يكون الشكر اليوم موصول كذلك لـ: § أخي في الله الأستاذ الفاضل علما وخلقا / عبد الله بشير عبد الله § ما شاء الله تبارك الله حفظك الله ورعاك أينما كنت وأينما حللت · حقيقة لا أعرف كيف أشكرك وجميع كلمات الشكر والثناء عاجزة عن أن توفيك حقك؛ ما أروعك وما أروع رقي تعاملكم معي وحرصكم على نشر العلم والمعرفة لمن يجهلها. v أدعو الله سبحانه وتعالى أن يجزيك بفضله ومن واسع عطائه وعلى قدر الله أجر: · رحابة وسعة صدرك وحلمك وصبرك على. · عدم تضجرك أو تأففك من كثرة تساؤلاتي وملاحظاتي. · سرعة ردكم وإجاباتكم الشافية الواعية عن ثقة وعلم وخبرة. · حسن متابعتكم لكل رد جديد على الموضوع والأروع والأجمل عباراتكم التي دوما تذيلون بها ردودكم مثل: ü جرب الملف واعلمنى بالنتائج. ü قم بتجربة الترحيل ولاحظ الترتيب وأي ملاحظات اذكرها وان شاء الله وبعونه نقوم بالواجب. ü أتمنى أن تجد طلبك في الملف ولا حرج في أي ملاحظات تراها تخدم العمل في ملفك. · وإن مثل هذه الردود تدل على رقي أخلاقكم ولا تأتي إلا ممن تمكن من علمه وأدواته زادكم الله من لدنه علما على علمكم. · كل ذلك أستاذي الفاضل ومعلمي رفع عني الحرج وجعلني أتجرأ وأسأل وبدون خشية وبكل أريحية عما أجهله وكلي ثقة ويقين بأني سأجد الرد والمعلومة الصحيحة ولوجه الله تعالى بدون بخل · وإني أستأذنكم في السماح لي بالسؤال في وقت لاحق بأمر الله تعالى حال ظهور أي استفسار أو ملحوظة بخصوص نفس الموضوع فالرجال أربعة: ü رجل يعلم.. ويعلم أنه يعلم *** فذلك (عالم) فصاحبوه واسألوه وتعلموا منه (وأنت منهم أستاذي الفاضل) ü ورجل يعلم.. ولا يعلم أنه يعلم *** فذلك (غافل) فأيقظوه ü ورجل لا يعلم.. ويعلم أنه لا يعلم *** فذلك (جاهل) فعلموه (وأنا منهم في الإكسيل) ü ورجل لا يعلم.. ولا يعلم أنه لا يعلم *** فذلك (أحمق) فاجتنبوه · وأخيرا وليس آخرا · أدعو الله عز وجل في علاه لكم ولنا ولكل من قرأ هذا التعليق: v أن يسعدكم الله في الدارين وأن يرزقكم بلا حساب وأن يفيض عليكم من علمه وأن يسقيكم من يد نبيه الشريفة شربة لا تظمأون بعدها أبدا وأن يجعل الفردوس الأعلى من الجنة مقاما ومستقرا لكم. آمين آمين آمين رب العالمين.

أشكرك أخي @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 لم ينتهي !؟!؟ لذا لم أقم بإضافتها أو التقيد بها أخي العزيز خليفة .

طيب يا فؤش انا مش عارف انت فاهم واللا انت بتحلب الاجابه علشان تكون كامله هو مش مقصود انى انزل الاجابة ناقصه بقدر ما هو مقصود ان تقتصر القاعدة على الفكرة المحاسبية فقط اه وشئ تانى علشان نقول عاوزين كل شئ يبقى بنتكلم فى برنامج كبير ما هو نقطه هتجر وراها نقطه تانيه مرتبطه بيها وده مش موضوعنا مبدئيا هو مينفعش ومش منطقى ان نفس المنتج فى فاتورة واحده يتكرر يعنى كل ما تيحب تعمل عملية بيع لنفس المنتج للتجربه فى كل مره تضيف سجل جديد لعمل فاتورة جديده يا فؤش أفندى صحصح وركز كده وانا قلت ملاحظة ان القاعدة تعتمد على شئ واحد فقط ضبط الحسابات بطريقة دقيقه ومرنه للحساب لرصد وجرد المبيعات بشكل صحيح نحلل كلامك ده يا فؤش أفندي تحليل كلامك بخصوص (سيناريو الشراء المتعدد بأسعار مختلفة) الدُفعة الكمية سعر الشراء الكمية المباعة الكمية المتبقية 1 24 10 4 20 2 24 12 10 14 3 24 9 0 24 المتبقي بالمخزون: 20 + 14 + 24 = 58 وحدة بثلاث أسعار مختلفة و أنت تتساءل: لما أبيع بعد كده… أبيع بأي سعر؟ هل أبيع بالسعر الأخير (9)؟ ولا الأعلى (12)؟ ولا (10)؟ هنا نرجع لفكرة "طريقة البيع" أو "طريقة صرف المخزون"، وهي شيء مهم جدًا يعتمد عليه النظام: الطرق المدعومة في جدول اعداد طرق البيع "طريقة صرف المخزون" : الطريقة شرح FIFO بيع من الدفعة الأقدم أولًا (10 جنيه أولًا ثم 12 ثم 9) LIFO بيع من الأحدث أولًا (9 جنيه أولًا ثم 12 ثم 10) HighestPrice بيع من الدُفعة الأعلى سعرًا أولًا LatestPrice بيع من أحدث دفعة (حسب التاريخ) وبالتالي: السعر الذي يظهر في الفاتورة عند إدخال الكمية يعتمد على طريقة البيع المختارة من الإعدادات. ما المشكلة اللي حصلت معاك؟ انت قلت : السعر اللي اتحدد في الفاتورة عند الرجوع ليها كان 109! وأن أنت مش متأكد هل هو متوسط ولا إيه... هنا فيه احتمالين: إما فى جدول الاعدادات لطريقة البيع تم اختيار طريقة البيع LatestPrice → وبالتالي تم اختيار أحدث دفعة (وسعرها ممكن يكون 109). أو فيه خطأ منطقي حصل أثناء إعادة تحميل الفاتورة (مثلاً: إعادة الحساب تم بطريقة مختلفة بعد الحفظ) هراجع الكود تانى اما بالنسبه للنقطه دى انا اعتمد فى عملى على المرونه وعلى الدقه بتقليل الاخطاء بقدر المستطاع يبقى النقطه اللى انت بتقولها غير انها هتزود خطوات الا ان المستخدم او الكاشير او البائع ممكن يغلط ليه انا بقه من الاول ما اسدد كل الثغرات اللى ممكن يحدث من ورائها اخطاء مقصودة او غير مقصودة يا فؤش افندى ولو تركت للبائع التحكم يا فؤش افندى ممكن يبيع مره من ده ومره أخرى من ده على المزاج بقه او بالنيه او بحسن وسوء الظن او حسب الغزاله جاى تهزر حضرتك يا افندم طيب انا قدمت فكرة وتطبيق عملى على اساس محاسبى صحيح وفى حالة رغبه صاحب العمل فى تغيير النظام المحاسبى يتم ذلك بدون التدخل فى تعديل الاكواد وفى النهايه اللى حابب ينفذ اى اقتراحات اخرى يمكنه عمل ذلك ما هو أنا مش هأقول لحد لا تنفذ اقتراحاتك التى تلبى رغباتك بكل بساطه تعتمد فكرتى على اختيار النظام المحاسبى لالية البيع من جدول اعداد خاص بذلك تحديد سعر الشراء وسعر البيع للدفعة وتاريخ وارد هذه الدفعه عند شرائها لعدم تدخل البائع فى كتابة السعر لتلافى اى مشكل محاسبية احتساب الكميات اليا وديناميكا بدون تدخل امكانية حساب الربح والخسارة بسهولة جدا جدا جدا بناء على ما سبق ومن واقع جدول الفواتير او التفاصيل وبناء على ما سبق عمل جرد مفصل لكل منتج حتى مع اختلاف اسعار البيع والشراء وتعدد الدفعات و تواريخ شراء الدفعات المختلفة طيب جرب المرفق ده يا فؤش أفندى ملاحظة أخيره الاستعلامات المستخدمه فى الأكواد هى : qryAvailableBatchesByProduct , qryAvailableByProduct أما بقية الاستعلامات مجرد استعلامات خدميه يمكن استخدامها فى : التقارير او فى عمل الجرد أو فى عمل حساب المبيعات والمشتريات لمعرفة هامش الربح أو الخسارة لم أهتم بموضوع ضبط الاكواد فى حالة التعديل على الفاتورة او المرتجعات أنا لست بصدد تقديم برنامج ولا بصدد تطبيق هذه الأفكار أنا فقط موضوعى هو اتمتتة عمليات البيع وفق التحكم بختيار طريقة البيع من جدول الاعدادات وفق الاصول المحاسبية التاليه وذلك على حسب فهمى المتواضع من البحث على الانترنت فى هذه الجزئية لإانا لست محاسب ولا أعلم شيئا عن المحاسبة ولا التكالبف قد أكون مخطئا أو مصيبا لذلك يرجى التأكد من أهل الإختصاص .. انا نصحتك وأنت براحتك علشان متجيش تزعق لى بعد كده FIFO بيع من الدفعة الأقدم أولًا (10 جنيه أولًا ثم 12 ثم 9) LIFO بيع من الأحدث أولًا (9 جنيه أولًا ثم 12 ثم 10) HighestPrice بيع من الدُفعة الأعلى سعرًا أولًا LatestPrice بيع من أحدث دفعة (حسب التاريخ) أتمتة عمليات البيع بكل الطرق (V 1.2).accdb