AbuuAhmed

يبدو أن الأستاذ محمد هشام فهم ما فهمته أنا أيضا لأن معادلته تعطي نفس ناتج دالتي. لقد قمت بالتعديل على الدالة بتمرير قيمة مهملة فقط لتشعر بأي تغيير في الصفحتين وتقوم بالحساب الذاتي. Function getBalance(DumpNum) As Long getBalance = Sheets("رئيسي ").Range("B1").End(xlDown) - _ Sheets("ورقة1").Range("B1").End(xlDown) End Function getBalance_02.xlsm

حياك الله أخي، لقد شرحت الكود في المشاركة السابقة، وها أنا أضع لك التعديل مرة أخرى لتركز فيه أكثر: '---------------------------------------- Col = 2 'العمود الثاني .. رقم الجلوس 'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر lr = Cells(Rows.Count, Col).End(xlUp).Row 'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks) '---------------------------------------- من الطبيعي إذا بدلت في الأرقام دون معرفتها ومعرفة جدواها ستوقف الكود. توضيح للأرقام: الرقم 2 هو رقم عمود رقم الجلوس وهو الرقم الوحيد الذي يمكنك التعديل عليه عند إزاحة/تغيير موقع العمود وبشرط أن لا تستخدم أسفل العمود أي يكون عند نهاية خاليا حتى نهاية الصفحة. الرقم 3 هو قيمة الرمز xlUp ويعني للأعلى، وهذا لا تلمسه بالمرة. الرقم 4 هو قيمة الرمز xlCellTypeBlanks ويعني الخلايا الفاضية. وهذ كذلك لا تلمسه بالمرة. بالنسبة لوظيفة الكود لم أحاول فهمه وخصوصا من بصمته تعرفت على كاتبه وهو من الخبراء المتمكنين والذي لا يمكنني أن أعدل على أكواده، فرجاءً تواصل معه لأي تعديل منعا للإحراج. تحياتي واعتذاري.

عمل لك دالة بالكود Function getBalance() getBalance = Sheets("رئيسي ").Range("B2").End(xlDown) - _ Sheets("ورقة1").Range("B2").End(xlDown) End Function getBalance_01.xlsm

على قد فهمي فأنا محسوب على منتدى الأكسس وكثير من أوامر ودوال الاكسل لا أستخدمها. Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box, Col As Integer Application.ScreenUpdating = False If ActiveSheet.Name <> "m" Then GoTo End_Me del_Empty_rows In_box = Application.InputBox("How Many Rows", , 14) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 8 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 '---------------------------------------- 'العمود الثاني Col = 2 'لإيجاد آخر سطر للعمود الثاني .. فهو يذهب لآخر الصفحة ثم يعود للخلف ليقف على آخر سطر 'lr = Cells(Rows.Count, 2).End(3).Row lr = Cells(Rows.Count, Col).End(xlUp).Row 'تقوم بإرجاع كائن نطاق يمثل كافة الخلايا الفاضية في العمود الثاني 'Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4) On Error Resume Next Set my_rg = Range(Cells(x, Col), Cells(lr, Col)).SpecialCells(xlCellTypeBlanks) '---------------------------------------- my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Sheets("m").Range("My_DEB").Copy _ Cells(t, 1) t = t + a + z + 1 Loop End_Me: Application.ScreenUpdating = True End Sub

اختصار للكود Function calcIEP(ByVal Period As Double) As Double Dim yr(), yy As Byte, mm As Byte Dim Pr(), Per As Double, Pos As Byte, p As Byte yr = Array(6, 5, 10, 5) Pr = Array(0.02, 0.018, 0.015, 0.04) Pos = InStrRev(Period, ".") mm = IIf(Pos = 0, 0, Mid(Period, Pos + 1)) Period = Fix(Period) For p = 1 To 4 yy = yr(p - 1): Per = Pr(p - 1) If Period > yy And p < 4 Then Period = Period - yy calcIEP = calcIEP + yy * Per Else calcIEP = calcIEP + Period * Per + (Per / 12 * mm) Exit For End If Next p End Function تم تنقيح الكود وتغيير المرفق. Calcul IEP_03.xlsm

تم تحويل نتائج الدالة إلى نص كما تحب. Option Explicit Function Frac(Num As Variant) As Double Frac = Num - Fix(Num) End Function Function ArrivalTimeDiff(ByVal ScheduledArrival As Variant, _ ByVal ActualArrival As Variant) As Variant Dim TimeDiff As Double ArrivalTimeDiff = "" If Not IsDate(ActualArrival) And Not IsNumeric(ActualArrival) Then Exit Function If Not IsDate(ScheduledArrival) And Not IsNumeric(ScheduledArrival) Then Exit Function If Trim(ActualArrival) = "" Or Trim(ScheduledArrival) = "" Then Exit Function ScheduledArrival = Frac(ScheduledArrival) * 24 ActualArrival = Frac(ActualArrival) * 24 TimeDiff = ActualArrival - ScheduledArrival If Abs(TimeDiff) >= 18 Then If ActualArrival < ScheduledArrival Then ActualArrival = ActualArrival + 24 Else ScheduledArrival = ScheduledArrival + 24 End If TimeDiff = ActualArrival - ScheduledArrival End If 'ArrivalTimeDiff = TimeDiff ArrivalTimeDiff = IIf(TimeDiff < 0, "-", " ") & Format(Abs(TimeDiff) / 24, "h:mm") End Function Trips Schedule_03.xlsm

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

بعد أن فهمت مطلبك بشكل دقيق، كنت أعتقد تريد تحسب مدة المشوار وبدون تركيز حسبت الوقتين بداية الرحلة ونهايته. عموما تنسيق وقت لا يقبل القيم بالسالب ويمكن عملها ولكن ستكون بتنسيق نص أي ستحرم من العمليات المحاسبية للنتائج. عملتها بشفرة البيزك. عندك بعض الأوقات بها ثواني وهي سبب عدم تطابقها مع نتائجك السابقة. Trips Schedule_02.xlsm

نعم هذه المعادلة الصحيحة والمناسبة لبياناتك غير الدقيقة ولولا الرهان حرام لراهنتك على دجاجة وخمسة كتاكيت بلدي.

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

محاولتي: Trips Schedule_01.xlsx

محاولتي: التنسيق الشرطي_01.xlsx

في المشاركة التالية تم اختيارها أفضل إجابة وبقدرة قادر حذفت الأفضلية 🙂

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

جرب المرفق اضطررت لعمل صفحة خاصة باسم "مصفوفة" تم حذف المرفق لوجود هفوة في هذين السطرين: tRow = 2 For row1 = 2 To lRow

هل تريدني أن أواصل أم اكتفيت؟ وإذا كان الجواب نعم فهل تريد المصفوفة تضم كل الأعمدة؟ أخبرني، لأواصل العمل، مع أني لاحظت تواجد أحد الزملاء المتمكنين ولا أعلم أبدأ العمل أم تراجع.

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

جرب هذا الكود: بعد تشغيله أول مرة خذ لك نظرة على الفاتورة، ثم شغله مرة ثانية للتخلص من السطور الفارغة. Option Explicit Sub Macro1() Dim row1 As Integer, row2 As Integer, col As Integer Dim lRow As Integer, tRow As Integer On Error Resume Next Sheets("الفواتير").Select lRow = Range("A1").SpecialCells(xlLastCell).row Range("A2:I" & lRow).Select ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Add Key:=Range("الفواتير[رقم الفاتورة]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort.SortFields. _ Add Key:=Range("الفواتير[الصنف]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("الفواتير").ListObjects("الفواتير").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With tRow = 3 For row1 = 3 To lRow If Cells(row1, 4) <> "" Then tRow = row1 For row2 = row1 + 1 To lRow If Cells(row2, 4) = Cells(tRow, 4) And _ Cells(row2, 8) = Cells(tRow, 8) Then Cells(tRow, 5) = Cells(tRow, 5) + Cells(row2, 5) For col = 1 To 9 Cells(row2, col) = "" Next col Else Exit For End If Next row2 End If Next row1 Range("A3").Select MsgBox "Done" End Sub تم إضافة هذا السطر: On Error Resume Next تم التعديل في هذ السطر: For row1 = 3 To lRow وإضافة هذين السطرين أيضا: Else Exit For

جرب محاولتي: تقريب الدينار العراقي_01.xlsx

شكرا لكم. تنقيح أخير للكود: Option Explicit Function CountPeople(ByVal ID As String) As Integer Dim People() As String, Item As String Dim Items As Integer, Pos As Integer Dim i As Integer, Count As Integer ID = Replace(ID, " ", "", 1, -1) If ID = "" Then Exit Function People = Split(ID & "+", "+") Items = UBound(People()) - 1 For i = 0 To Items Item = People(i) Select Case Item Case "INF": 'Count = Count + 0 Case "SGL": Count = Count + 1 Case "DBL": Count = Count + 2 Case "TRP": Count = Count + 3 Case Else Pos = InStr(1, Item, "CH(") If Pos > 0 Then If Pos = 1 Then Count = Count + 1 Else Count = Count + Val(Left(Item, Pos - 1)) End If End If End Select Next i CountPeople = Count End Function

محاولتي: استخراج أعداد الغرف_01.xlsm

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

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

تم إصلاح الخلل وعمل عدة تنقيحات: حضور وإنصراف_05.xlsb

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