AbuuAhmed

حياك الله أستاذ أصل الكود ليس لي وربما كاتبه هو سيدة باسم "ساجدة" حسب اسم الموديول (الوحدة النمطية). والحقيقة أن الأصل لم يتم التعديل عليه في المعالجة والحساب بل تمت إضافات رتوش عليه فقط وتعديل عدد المواد و درجة القرار، فالفضل هو لكاتب الإجراء الأصل. كذلك تمت إضافات في آخر الكود خاصة بصفحة القائمة المطلوبة. تمت تحسينات عدة ، قد تكتشفوها عند استعمال الملف. ود توزيع القرار_18.xlsm

بدل هذا السطر: If .Cells(ss, 16) <> "ناجح" Then بهذا السطر: If Not .Cells(ss, 16) Like "ناجح*" Then إذا أحببت إضافة مواد الغياب على مواد الإكمال في خانة النتيجة، أخبرني.

جرب المرفق: كود توزيع القرار_16.xlsm

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

جرب الآن كود توزيع القرار_15.xlsm

اختصار المطلوب : لا تكتب حرف "غ" في صفحة المسودة ، دع خلايا الغياب بدون أي بيانات.

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

جرب جساب الفرق بين تاريخين.xlsx

أحسنت ، قلت ما لا نستطيع قوله. وما لم تقله ربما أكثر وأكبر.

أخمن أنك قد بدلت في صفحة المسودة بحذف سطور أو أعمدة ، على كل لا يمكن التعديل بدون إرفاق الملف نفسه.

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

أستاذ أنا معتذر من المواصلة مع المنتدى ولكن ما هان علي أتركك وأترك هالموضوع بعد الجهد الكبير الذي بذلناه.أستاذ أعتقد أنك تريد للراسبين أن تعود درجاتهم الأصلية قبل درجة الإكمال أي قبل التعديل ، صحيح؟ جرب الآن ، وإن شاء يكون فحصك دقيق ونهائي ويكون تعديلي صحيح ونهائي أيضا. كود توزيع القرار_14.xlsm

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

اعتذار منكم أساتذتي

سأغيب عنكم وقد يشاء الله أن أعود لكم ولكن تجربتي في هذا الموقع المبارك لم تكن مريحة لي ، فأمور عدة لم تشعرني بالراحة للمواصلة. شكر خاص للأستاذ @Ali Mohamed Ali فهو الوحيد حسب ما أتذكر من شجعني وتابع عملي وشاركني بتعليقاته وإعجاباته. كما أشكر الأستاذ @jaffar من منتدى الأكسس الذي اختارني من ضمن الخبراء وكذلك من رشحني له. كما أشكر كل من شاركني وتابعني واستفاد من مشاركاتي. سامحوني وادعوا لي موفقين جميعا.

لديك الآن 4 خيارات عن طريق الأزرار/الضغطات في صفحة المسودة ..موفقين. كود توزيع القرار_12.xlsm

الملف بعد التعديل يمكنني عمل زر للتبديل بين اتجاه النص إذا رغبت. طلب خاص مني للمشرفي بحذف كل المرفقات السابقة والإبقاء على أول ملف في المشاركة الأولى وآخر ملف في المشاركة الأخيرة وشكرا لكم مقدما. كود توزيع القرار_11.xlsm

مثال للدوال systemUmAlQura.mdb

مثال لاستخدام الدالتين ، وقد تم فصل أمر الفتح والإغلاق في هذين الحدثين Private Sub Workbook_Open() Call OpenxlApp End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call ClosexlApp End Sub UmAlqura4Excel_01.xlsm

تعديلات عديدة ممكن توضيحها في وقت آخر. الآن يمكنكم تبديل الأعمدة "العواميد" للفاتورة فقط دون مشاكل إن شاء الله ، أما عند تبديل أسماء الأعمدة فيجب عليكم تبديلها أيضا في الماكرو. موفقين. Invoices-j3_03.xlsm

لم أفهم كلامك جيدا ، الخلاصة أنك لا تريد نتائج أصغر من صفر ، صحيح؟ موعد الرواتب_03.xlsx

تعديل جزئي فقط ، وإذا توفر لدي وقت واصلت معك. Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Cells.CountLarge > 1 Then Exit Sub If .Count > 1 Then Exit Sub 'If .Row > 2 And .Column = 7 Then If .Row >= 2 And .Column = 8 Then Application.EnableEvents = False Set fo = Sheets("Items2023") If Range("B" & .Row) <> "" And Range("F" & .Row) <> "" Then ln = WorksheetFunction.Match(.Offset(0, -5), fo.Range("C:C"), 0) x = fo.Cells(ln, 5) 'Stok initial sur la feuille OldStock2021-2022 Cells(.Row, 6) = x 'Stock initial Cells(.Row, 18) = "Locked" s = IIf(.Offset(0, -1) = "Sell", -1, 1) 'sens du mouvement = 1 pour retour,-1 pour vente Cells(.Row, 12) = .Value * s + x 'Stock final fo.Range("E" & ln) = .Value * s + x 'Nouveau stock mis à jour Range("A" & .Row) = Date 'ou = Now si on veut l'horodate Else MsgBox "Saisies incomplètes.", 16 Exit Sub End If End If Application.EnableEvents = True End With End Sub والتغيير في هذا السطر: 'If .Row > 2 And .Column = 7 Then If .Row >= 2 And .Column = 8 Then

كما العنوان ومدى الدالتين: أم القـرى : بين 1317/08/29 و 1450/12/29 الميلادي : بين 1900/01/01 و 2029/05/13 طبعا لمن سيستخدمهما عليه أن يفصل أوامر فتح الإكسل وإغلاقه عن الدوال ووضعهم مع الفتح والخروج من مشروع الإكسل ، لتجنب البطء مع كل نداء للدالتين. Option Explicit Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Sub OpenxlApp() Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) End Sub Sub ClosexlApp() xlBook.Close SaveChanges:=False xlApp.Quit End Sub 'AbuuAhmed Function sysUmTest(ByVal UmAlqura As String) As String Dim Dash1 As Byte, Dash2 As Byte, Dash3 As Byte Dim Part1 As String, Part2 As String Dim Part3 As String, Part4 As String On Error Resume Next Part4 = Replace(UmAlqura, "/", "-") If Not IsNumeric(Replace(Part4, "-", "", 1)) Then Exit Function Dash1 = InStr(1, Part4, "-"): If Dash1 = 0 Then Exit Function Dash2 = InStr(Dash1 + 1, Part4, "-"): If Dash2 = 0 Then Exit Function Dash3 = InStr(Dash2 + 1, Part4, "-"): If Dash3 > 0 Then Exit Function Part1 = Left(Part4, Dash1 - 1) Part2 = Mid(Part4, Dash1 + 1, Dash2 - Dash1 - 1) Part3 = Mid(Part4, Dash2 + 1) If Len(Part1) < 4 And Len(Part3) < 4 Then Exit Function If Len(Part1) = 1 Then Part1 = Format(Part1, "00") If Len(Part2) = 1 Then Part2 = Format(Part2, "00") If Len(Part3) = 1 Then Part3 = Format(Part3, "00") If Len(Part1) = 2 Then Part4 = Part1 Part1 = Part3 Part3 = Part4 End If If Not (Val(Part1) >= 1300 And Val(Part1) <= 1600) Then Exit Function If Not (Val(Part2) >= 1 And Val(Part2) <= 12) Then Exit Function If Not (Val(Part3) >= 1 And Val(Part3) <= 30) Then Exit Function sysUmTest = Part1 & "-" & Part2 & "-" & Part3 End Function Function sysUm2Greg(ByVal UmAlqura As String) As Long Dim CurCal As VbCalendar Dim Greg As Long, Days As Long Dim Hdd As Byte On Error Resume Next UmAlqura = sysUmTest(UmAlqura) If UmAlqura = "" Or UmAlqura < "1317-08-29" Or UmAlqura > "1450-12-29" Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A2").Formula = "=LEFT(TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@""),2)" Hdd = Right(UmAlqura, 2) CurCal = Calendar Calendar = vbCalHijri Greg = DateSerial(Left(UmAlqura, 4), Mid(UmAlqura, 6, 2), Hdd) Calendar = CurCal .Range("A1") = Greg If Hdd = .Range("A2") Then sysUm2Greg = Greg Else For Days = Greg + 2 To Greg - 2 Step -1 .Range("A1") = Days If Hdd = .Range("A2") Then Exit For Next Days sysUm2Greg = IIf(Abs(Days - Greg) > 2, Greg, Days) End If End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Function sysGreg2Um(ByVal Greg As Long) As String On Error Resume Next If Greg < DateSerial(1900, 1, 1) Then Exit Function If Greg > DateSerial(2029, 5, 13) Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A1") = Greg .Range("A2").Formula = "=TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@"")" sysGreg2Um = .Range("A2") End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Sub sysUmTesting() Dim UmAlqura As String UmAlqura = "30-6-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) Debug.Print UmAlqura = "1-7-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) End Sub

كما العنوان ومدى الدالتين: أم القـرى : بين 1317/08/29 و 1450/12/29 الميلادي : بين 1900/01/01 و 2029/05/13 طبعا لمن سيستخدمهما عليه أن يفصل أوامر فتح الإكسل وإغلاقه عن الدوال ووضعهم مع الفتح والخروج من مشروع الأكسس ، لتجنب البطء مع كل نداء للدالتين. Option Explicit Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Sub OpenxlApp() Set xlApp = CreateObject("Excel.Application") Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) End Sub Sub ClosexlApp() xlBook.Close SaveChanges:=False xlApp.Quit End Sub 'AbuuAhmed Function sysUmTest(ByVal UmAlqura As String) As String Dim Dash1 As Byte, Dash2 As Byte, Dash3 As Byte Dim Part1 As String, Part2 As String Dim Part3 As String, Part4 As String On Error Resume Next Part4 = Replace(UmAlqura, "/", "-") If Not IsNumeric(Replace(Part4, "-", "", 1)) Then Exit Function Dash1 = InStr(1, Part4, "-"): If Dash1 = 0 Then Exit Function Dash2 = InStr(Dash1 + 1, Part4, "-"): If Dash2 = 0 Then Exit Function Dash3 = InStr(Dash2 + 1, Part4, "-"): If Dash3 > 0 Then Exit Function Part1 = Left(Part4, Dash1 - 1) Part2 = Mid(Part4, Dash1 + 1, Dash2 - Dash1 - 1) Part3 = Mid(Part4, Dash2 + 1) If Len(Part1) < 4 And Len(Part3) < 4 Then Exit Function If Len(Part1) = 1 Then Part1 = Format(Part1, "00") If Len(Part2) = 1 Then Part2 = Format(Part2, "00") If Len(Part3) = 1 Then Part3 = Format(Part3, "00") If Len(Part1) = 2 Then Part4 = Part1 Part1 = Part3 Part3 = Part4 End If If Not (Val(Part1) >= 1300 And Val(Part1) <= 1600) Then Exit Function If Not (Val(Part2) >= 1 And Val(Part2) <= 12) Then Exit Function If Not (Val(Part3) >= 1 And Val(Part3) <= 30) Then Exit Function sysUmTest = Part1 & "-" & Part2 & "-" & Part3 End Function Function sysUm2Greg(ByVal UmAlqura As String) As Long Dim CurCal As VbCalendar Dim Greg As Long, Days As Long Dim Hdd As Byte On Error Resume Next UmAlqura = sysUmTest(UmAlqura) If UmAlqura = "" Or UmAlqura < "1317-08-29" Or UmAlqura > "1450-12-29" Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A2").Formula = "=LEFT(TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@""),2)" Hdd = Right(UmAlqura, 2) CurCal = Calendar Calendar = vbCalHijri Greg = DateSerial(Left(UmAlqura, 4), Mid(UmAlqura, 6, 2), Hdd) Calendar = CurCal .Range("A1") = Greg If Hdd = .Range("A2") Then sysUm2Greg = Greg Else For Days = Greg + 2 To Greg - 2 Step -1 .Range("A1") = Days If Hdd = .Range("A2") Then Exit For Next Days sysUm2Greg = IIf(Abs(Days - Greg) > 2, Greg, Days) End If End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Function sysGreg2Um(ByVal Greg As Long) As String On Error Resume Next If Greg < DateSerial(1900, 1, 1) Then Exit Function If Greg > DateSerial(2029, 5, 13) Then Exit Function Call OpenxlApp 'لتسريع الدالة يفضل نقل هذا السطر عند فتح الملف/البرنامج With xlSheet .Range("A1").NumberFormat = "m/d/yyyy" .Range("A2").NumberFormat = "0" .Range("A1") = Greg .Range("A2").Formula = "=TEXT(A1,""[$-1170000]B2dd/mm/yyyy;@"")" sysGreg2Um = .Range("A2") End With Call ClosexlApp 'لتسريع الدالة يفضل نقل هذا السطر عند اغلاق الملف/البرنامج End Function Sub sysUmTesting() Dim UmAlqura As String UmAlqura = "30-6-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) Debug.Print UmAlqura = "1-7-1446" Debug.Print CDate(sysUm2Greg(UmAlqura)) Debug.Print sysGreg2Um(sysUm2Greg(UmAlqura)) End Sub