AbuuAhmed

إلى المشرفين المحترمين: لماذا تم حذف هذه المشاركة المشار إليها في سؤالي!! حذف آخر كود منقح يحرف المناقشة عن مفهومها الصحيح!! وفيها خلاصة الحل (الزبدة). نسخة مع التحية إلى @محمد طاهر عرفه الكود المحذوف والمقصود في سؤالي أعلى المشاركة: Sub KeepZeroDuplicates() Dim ws As Worksheet, CheckRange As Range Dim data As Variant, checkCols As Variant Dim row1 As Long, row2 As Long Application.ScreenUpdating = False 'Set worksheet and last row Set ws = ActiveSheet 'Replace with your sheet name if needed row1 = ws.Cells(ws.Rows.count, "A").End(xlUp).row 'Store data in an array for efficient processing data = ws.Range("A1:E" & row1).Value 'Adjust range as needed 'Specify columns to check for duplicates checkCols = Array(1, 4, 5) 'Replace with column numbers 'Loop through data array For row1 = 2 To UBound(data) 'Start from second row For row2 = 2 To row1 - 1 DoEvents 'Check for duplicate in specified columns If IsDuplicate(data, row1, row2, checkCols) Then 'If Duplicate and zero quantity If data(row1, 3) = 0 Then ws.Cells(row1, 1) = "2Del" Exit For End If End If Next row2 Next row1 For row1 = UBound(data) To 2 Step -1 If Cells(row1, 1) = "2Del" Then Rows(row1).Delete Shift:=xlUp End If Next row1 Application.ScreenUpdating = True MsgBox "Done" End Sub Function IsDuplicate(data As Variant, row1 As Long, row2 As Long, checkCols As Variant) As Boolean Dim index As Long For index = LBound(checkCols) To UBound(checkCols) If data(row1, checkCols(index)) <> data(row2, checkCols(index)) Then Exit Function End If Next index IsDuplicate = True End Function

هل جربت الكود في مشاركتي قبل الأخيرة ولم ينجح؟!! عموما أنا حليت لك أكبر مشكلتين في الكود: أولهما مفتاح التكرار حيث بدلته من: checkCols = Array(1, 2, 3, 4, 5) إلى: checkCols = Array(1, 4, 5) وكذلك تبديل عملية الحذف بحيث تكون من الأخير إلى الأول وهنا لا تحتاج إلى ضبط متغير row1 بعد كل عملية حذف ولا نحتاج لمقاطعة حلقة التكرار. يفترض أنك تراعي تعبنا بدلا من أن تأخذ جزء من هنا وجزء من هناك ثم ترجع بعبارة رأيت المشكلة أو وجدت الحل. ميزة الحل السابق أن يحافظ على ترتيب الادخال. سؤال لك الخيار في الرد عليه: هل التعديلات من عملك أم هناك من تتواصل معه خارج المنتدى؟

جرب التعديل واختبره جيدا توزيع الدفعات_03.xlsx

إذا شعرت بثقل/بطء المعادلات يمكن تحويلها إلى كود فيجوال. توزيع الدفعات_02.xlsx

وهذا تنقيح للكود بطريقتي: Sub RemoveZeroDuplicates() Dim ws As Worksheet, count As Long Dim row As Long, lRow As Long Application.ScreenUpdating = False Sheets("Sheet3").Select Set ws = ActiveSheet With ws lRow = ActiveCell.SpecialCells(xlLastCell).row For row = lRow To 2 Step -1 If .Cells(row, 8) = "Yes" Then count = count + 1 .Rows(row).Delete Shift:=xlUp End If Next row End With Application.ScreenUpdating = True MsgBox "تم حذف " & count & " سجل" End Sub

فقط قبل نصف ساعة فهمت موضوعك، دائما عند تقديم مثال يجب تقديم الحل/الناتج المطلوب، بمعني تقول هذه المعادلة يفترض أن يكون جوابها هكذا. اختصرت لك كل هالمشقة والأكواد بسطر واحد فقط، آمل التجربة والعودة لنا بملاحظاتك. وبعد المزيد من التجارب أضفت سطر آخر 🙂 Function myRound(MainVal As Double, RoundVal As Double) As Double Dim Adj As Double Adj = (0.1 / RoundVal) * Sgn(MainVal) myRound = Round(MainVal / RoundVal + Adj) * RoundVal End Function وهذا سطر للاحتراز يمكن إضافته بداية الدالة عند الرغبة: If RoundVal < 10 Or RoundVal Mod 10 <> 0 Then Exit Function

حل آخر: بدل هذا السطر: X2 = MainVal \ RoundVal بهذا السطر: X2 = Fix(MainVal / RoundVal)

جرب محاولتي ولكن عملتها "عمياني"، ما أدري بالضبط المطلوب من الدالة ولكني أجريت كل العمليات على صفحة اكسل، اختبرها وخبرني حتى ولو وجدت حل آخر، ربما نستطيع تطبيق الفكرة على دوال كثيرة نتائجها تتجاوز نطاق متغيرات الـ vba. المصنف_03.xlsm

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

فكرة أخرى جنب فكرة الأستاذ طارق محمود بيانات الموظفين_02.xlsm

20 / 365.2425 * 354.367 240 / 365.2425 * 354.367

كل عام وأنتم بخير احرص تضيف الكود في موديول الصفحة نفسها أفضل من إضافته في موديول عام، أو أن تختار الصفحة الهدف أولا قبل تشغيل الكود. عدل في السطر بأن تضغ بعد علامة = رقم آخر سطر في الصفحة بدلا من الأمر مثلا: lRow = 300

بدل في رقم الإزاحة (2) واجعله 0 Cells(.Row, .Column + 2) = NewValue

محاولتي حسب فهمي التشغيل من الكود نفسه. الارقام والنصوص_02.xlsm

لا بأس عليك، أجر وعافية.

دالة round تعمل مع الأرقام الموجبة والسالبة بنفس الطريقة، لا تحتاج إلى استخدام دالة if

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

أنا تخصصي أكسس أكثر منه اكسل. أضفت 3 وحدات نمطية (موديولات) لـ أبو هادي، من له قدرة في استخدام امكانيات الاكسل في استخدام تقويم أم القرى فليفدنا. هناك شرط يجب أن تنتبه له وهو خصائص خلايا التاريخ يجب أن تكون لتقويم أم القرى وإلا ستتفاجأ بنتائج خاطئة. فرق مدة إيجار بين تاريخين هجري_03.xlsm

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

حل عن طريق الـ vba، دالة لحساب أي يوم من الأسبوع بين تاريخين WeekDaysCount_01.xlsm

عدلت في المعادلة ربما تعمل معك، جرب =IF(F8*0.0199<1.99,1.99,IF(F8*0.0199>2.99,2.99,F8*0.0199))

الدالة، تتطلب النص وترتيب الدرجة في النص 1 للأول 2 للثاني: Option Explicit Function GetDeg(ByVal inText As String, DegSeq As Byte) As Variant Dim Pos1 As Integer, Pos2 As Integer Dim Deg As Variant GetDeg = "" If DegSeq < 1 Or DegSeq > 2 Then Exit Function Do While InStr(1, inText, " ") > 0 inText = Replace(inText, " ", " ") Loop Pos2 = InStr(1, inText, " درج") If Pos2 = 0 Then Exit Function If DegSeq = 2 Then Pos2 = InStr(Pos2 + 1, inText, " درج") If Pos2 = 0 Then Exit Function End If Pos1 = InStrRev(inText, " ", Pos2 - 1) If Pos1 > 0 And Pos2 > 0 Then Deg = Mid(inText, Pos1 + 1, Pos2 - Pos1 - 1) End If If IsNumeric(Deg) Then GetDeg = Val(Deg) End Function ضفه في ملفك أو انشئ ملف جديد ووحدة نمطية جديدة والصق الشفرة/الكود

عملت لك حل بالكود فصل الارقام عن الاحرف_01.xlsm

طلبك الآن يخالف طلبك الأول ربما أنك لا تريد أن ترى في الأيام الباقي 30 يوم، إذا كان كذلك اعتره شهر وأضفه على الشهور وصفر الأيام. طول الشهر 20 يوم_04.xlsm

نعم صحيح، ولا تعديل في كودر vba طول الشهر 20 يوم_03.xlsm