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

كل عام وجميع منتسبي منتدانا الغالي (أوفيسنا) بخير وصحة وعافية أعاده الله علينا وعليكم وعلى أمتنا الاسلامية بالخير واليمن والبركات.

أخي الفاضل المحترم الكريم زادك الله من علمه كل عام وانت طيب وبخير وبصحة جيدة وفي أحسن حال أخي المبجل ( foksh )

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("الاختلافات"): End Property Sub Button1_Click() Dim i As Long SetApp False For i = 3 To 62 WS.Rows(i).Hidden = (Application.WorksheetFunction.CountA(WS.Range("B" & i & ":R" & i)) = 0) Next i SetApp True End Sub Sub Button49_Click(): SetApp False: WS.Rows("3:62").Hidden = False: SetApp True: End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub كود إخفاء وإظهار.xlsb

أعتقد ان إستبدال هدا السطر سيوفي بالغرض من If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, 13).Value = Application.Index(v, Evaluate("ROW(1:" & xtbl & ")"), Evaluate("COLUMN(1:13)")) End If إلى If xtbl > 0 Then If xtbl = 1 Then Sh1.Range("A5").Resize(1, 13).Value = v Else Sh1.Range("A5").Resize(xtbl, 13).Value = v End If End If بطريقة مختلفة وأسرع نوعا ما Private Sub CommandButton1_Click() Dim i&, r&, c&, k&, t&, f&, xtbl&, lastRow&, n As Boolean, ok As Boolean, val$ Dim s, data, a(), ky(), tb(), j(), criteria() SetApp False ReDim ky(1 To MaxCombo): ReDim tb(1 To MaxCombo): ReDim j(1 To MaxCombo) For i = 1 To MaxCombo val = Trim(LCase(Me("ComboBox" & i).Value)) If val <> "" And val <> "*" Then ky(i) = val: n = True Else ky(i) = "" Next If Not n Then MsgBox "الرجاء تحديد معايير البحث", vbExclamation: GoTo CleanUp For i = 1 To MaxCombo If ky(i) <> "" Then f = f + 1: tb(f) = ColArr(i - 1): j(f) = ky(i) Next With Sh1 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then .Range("A5:M" & lastRow).ClearContents End With data = OnRng: k = UBound(data, 1): t = 13 ReDim a(1 To k, 1 To t), criteria(1 To f) For r = 1 To k ok = True For i = 1 To f s = data(r, tb(i)) criteria(i) = IIf(IsDate(s), Format$(s, "yyyy/mm/dd"), LCase(Trim(CStr(s)))) If criteria(i) <> j(i) Then ok = False: Exit For Next If ok Then xtbl = xtbl + 1 For c = 1 To t: a(xtbl, c) = data(r, c): Next If IsDate(a(xtbl, 9)) Then a(xtbl, 8) = xDayName(Format(a(xtbl, 9), "dddd")) If IsDate(a(xtbl, 12)) Then a(xtbl, 11) = xDayName(Format(a(xtbl, 12), "dddd")) End If Next If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, t).Value = a AddBorders Sh1.Name CleanUp: SetApp True End Sub توحيد البحث في شيت واحد v7.xlsb

المشكلة الاساسية هي هذه فنحن لم نستطيع فتح اي نموذج او تقرير عموما من حيث المبدأ فتصدير التقرير الى الاكسل يتطلب استيفاء بعض الشروط فليس أي تقرير يمكن تصديره وحتى بعد التصدير لن تظهر جميع عناصره كما هي في التقرير مثال عنوان التقرير وكذا التسميات التوضيحية وغيرها من الاختلافات والطريقة الاسهل هي تصدير الاستعلام فهو أقرب مايكون الى ورقة أكسل قم بإعداد إستعلام يشمل جميع الأعمدة المطلوبة فعلى اعتبار ان الاستعلام المراد تصديره اسمه qryExportingData وتريد تصديرة الى نفس المجلد الخاص بالتطبيق بالإسم ExportingData.xlsx فبإستخدام الامر DoCmd.OutputTo acOutputQuery, "qryExportingData", acFormatXLSX, CurrentProject.path & "\ExportingData.xlsx", True, , , acExportQualityPrint سينتج لك ملف أكسل بنتيجة الإستعلام بنفس عناوين وترتيب الأعمدة

العفو يا صديقي ، ولا يهمك ,, لك مني نصيحة وهي الابتعاد عن التسميات العربية للحقول أو الجداول أو النماذج أو مكوناتها .. لذا قمت بتغيير اسم مربع النص الخاص بالحالة = Tx_Status . وعليه فقد استخدمت التنسيق الشرطي لتنفيذ طلبك مع دالة جديدة لإضافة كلمة Expired أو Current ,, حيث الدالة الجديدة :- Function GetDurationStatus(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then GetDurationStatus = "" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If If diff < 1 Then GetDurationStatus = "Expired" Else GetDurationStatus = "Current" End If End Function صورة توضيحية :- الملف المرفق :- تفقيط التاريخ 1.accdb

اعتذر عن التأخير .. في مديول جديد ، الصق الكود التالي :- Function DurationToWords(StartDate As Variant, EndDate As Variant) As String Dim diff As Integer If IsNull(StartDate) Or IsNull(EndDate) Then DurationToWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If diff = DateDiff("yyyy", StartDate, EndDate) If Month(EndDate) < Month(StartDate) Or _ (Month(EndDate) = Month(StartDate) And Day(EndDate) < Day(StartDate)) Then diff = diff - 1 End If Select Case diff Case Is < 0 DurationToWords = "تاريخ غير صالح" Case 0 DurationToWords = "أقل من سنة" Case 1 DurationToWords = "سنة واحدة" Case 2 DurationToWords = "سنتان" Case 3 To 10 DurationToWords = NumberToArabicWords(diff, True) & " سنوات" Case Else DurationToWords = NumberToArabicWords(diff, True) & " سنة" End Select 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 وفي حدث بعد التحديث لمربعي نص التاريخ :- Private Sub date2_AfterUpdate() Me.mo = DurationToWords([date1], [date2]) End Sub Private Sub date1_AfterUpdate() Me.mo = DurationToWords([date1], [date2]) End Sub تفقيط التاريخ 1.accdb

اشكرك على رأيك @غريب طرابلس لكل لغة ولها عيوب ونقط ضعف وبيدك استعمال آمن وتكلفة ممتازة افضل من هدر المال وارتفاع الاشتركات للبحث عن ثغرات وشاش اقصد على حسب الامكانيات العميل والي يطلب هذا الطلب غالب ان تكون شركة ولها فروع للتحصيل او حكومي بنطاق واسع وكليهما حسب نوع الخدمة ونطاق ويفضلون الآمن SH.. بنطور الاكسس جرب النافذه كامل الشاشة والعناصر كما هي اما بخصوص الدالة كل من طرق بستخدامها وسابق تعديل كان الريبن شريط الاكسس تشطيف وتعامل مع هذه الدالة استاذي @ابو جودي ☕❤️🌹 وبتحجيم الشاشة والعناصر والقياس واساتذه اخرى وحتى الاجنبي فدالة الي فوق افضلهم

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

بسم الله الرحمن الرحيم للتسهيل في استخراج مواد الرسوب للطلبة تم عمل هذه الدالة لاستخراج المواد الراسب فيها او متغيب يشترط وجود صف الدرجة العظمى ودرجة النجاح نضع هذا الكود في موديول Function ASEEL(x As Range) Dim D As String For Each Rng In x If Rng = "" Then GoTo 1 If Rng < Cells(5, Rng.Column) Or Rng = "غ" Then D = " (" & Cells(3, Rng.Column).Text & ")" & D End If 1 Next If D <> "" Then ASEEL = D Else ASEEL = "ناجح ومنقول" End If End Function ونضع هذه الدالة في الملاحظات داخل الكشف ونسحبها نزولا كما موضح بالمرفق =ASEEL(D6:J6) وشكرا دالة معرفة لاستخراج مواد الرسوب.rar

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

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