AbuuAhmed

لم أفهم كلامك جيدا ، الخلاصة أنك لا تريد نتائج أصغر من صفر ، صحيح؟ موعد الرواتب_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

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

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

أخطأت في رابط المثال الذي يضم 3 طرق حساب الترقيات

أخبرتكم أن النسخة السابقة هي الأخيرة ولكن سيطرت علي فكرة في الوصول إلى تاريخ أم القرى بدون فرق ، وقد نجحت الفكرة والحمد لله. سأطبقها إن شاء على مثال للأكسس الحقوق الفكرية محفوظة 🙂 كشف انتهاء هويات الموظفين_05.xlsm

معادلة أخرى موعد الرواتب_02.xlsx

السلام عليكم ..هل يمكن استخدام التقويم ومن منكم له تجارب سابقة يفيدنا ويكفينا عبئ البحث؟ وشكرا لكم.

جرب الآن وارجع لنا بالنتيجة ..مع ملاحظة أني لعبت في البيانات نمودج_02.xlsb

@محمد ابومروان 🙂 ظلمت الإكسل ، مع أني محترف كتابة شفرات ولكن لا أنصحك باللجوء إلى الفيجول إلا إذا عجز الإكسل عن الحل. موفقين. وهذا إذا أردته للنموذج Private Sub TextBox2_Change() Dim cd As String cd = Me.ActiveControl If Len(cd) <> 14 Then Exit Sub Me.TextBox3 = DateSerial(1700 + Left(cd, 1) * 100 + Mid(cd, 2, 2), Mid(cd, 4, 2), Mid(cd, 6, 2)) End Sub

علاج مؤقت ، وقد يكون له آثار جانبية عطلت عبارة if في دالة UmCDate والمشكلة بسبب أن الشفرة اعتبرت أن التاريخ على ما أعتقد ميلادي ويوم 30 أكبر من مدة شهر فبراير.

جرب الآن Book12_03.xlsm

أحتاج رقم قومي بعد عام 1999 Book12_02.xlsm

التقويم المطلوب هجري النظام أم أم القرى؟

جرب الآن Gyab_New_03.rar

جرب وخبرنا list_03.xlsx

يمكنت تبديل "" إلى صفر من خلال المعادلة Copy of Book1_02.xlsx

لا أنصح باللجوء إلى الفيجوال إلا في حالة استعصاء عمل المعادلات المعقدة في الإكسل. بدل الحدث من SelectionChange إلى حدث Change وجرب.

عملك سليم ويمكنك الحصول على مطلبك من نفس الاستعلام أو بعمل استعلام ثاني مصدره الاستعلام الأول. تعديلي في الاستعلام الأول Uni_02.rar

أضفت لك أكواد تقويم أم القرى من موقع أبو هادي مع تصرف بسيط مني في دالة UmDateDiff. حساب الترقيات.xlsm

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

لا يمكن أن نصل إلى تحويل للتاريخ بمعادلة من سطر واحد وباستخدام المتوسطات. ما عملته أنا فقط للحصول على السنة الهجرية ليس إلا ، فلا يذهب تعبكم سدى ، فالتقاويم لها قوانين وتفاصيل كثيرة مثل مدد الشهور ونطام الدورات والكبس. هذه دالة فحصي للمعادلة لمن يريد أن يكثر من الاختبارات واللعب على قيمة الضبط: Sub HijriYearTest() Dim Hyy As Long Dim Days As Long Dim Greg As Long Dim Hijri1 As Long Dim Hijri2 As Double For Hyy = 1 To 9666 Greg = Hijri2Greg(Hyy, 1, 1) For Days = Greg - 1 To Greg Hijri1 = Left(Greg2Hijri(CDate(Days)), 4) 'Hijri2 = (Days + 466580.47) / 354.366666666667 + 1 Hijri2 = (Days + 466581 - 0.53) / (10631 / 30) + 1 If Hijri1 <> Fix(Hijri2) Then Debug.Print CDate(Days), Hijri1, Hijri2 End If Next Days Next Hyy Debug.Print "Done" End Sub

(Date + 466581 - 0.53) / (10631 / 30) + 1 Date يمثل التاريخ الميلادي للأكسس والإكسل و الـ vba 466581 هو الرقم التسلسلي لبداية التقويم الميلادي في 18/07/0622 زائدا واحد حتى تكون النتيجة المطلوبة تساوي يوم واحد. طبعا الرقم التسلسلي يساوي 466580- نصفره ونضيف عليه يوم واحد وهو قيمة بداية التقويم الهجري (أول يوم). (10631 / 30) هو طول السنة الهجرية بالأيام وناتجها 354.367 ولكني فضلت استخدم عملية التقسيم حتى أحصل على كسر مفتوح لمزيد من الدقة. 0.53 هو لعملية ضبط adjustment حصلت عليه بعد عدة تجارب/اختبارات وتظهر حاجته غالبا في آخر يوم في السنة وأحيانا في أول يوم أيضا. 1 هو للسنة الناقصة (غير المكتملة)