عبدالله بشير عبدالله

السلام عليكم ورحمة الله وبركانه اظافة الى حل استاذنا احمد يوسف جزاه الله خيرا يمكن استخدام كود لاستدعاء اجور الطعام مع الاستحقاق مع اعتماد الخلايا الصفراء حال عدم وجود تاريخ معادلة بشروط1.xlsb

وعليكم السلام ورحمة الله وبركانه الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then Dim c As Range For Each c In Target If c.Value <> "" And IsEmpty(c.Offset(0, 1).Value) Then c.Offset(0, 1).Value = Date End If Next c End If If Not Intersect(Target, Me.Range("D:D")) Is Nothing Then Dim dCell As Range For Each dCell In Target If dCell.Offset(0, 2).Value = "إجازة" Then If Application.WorksheetFunction.CountIfs(Me.Range("D:D"), dCell.Value, Me.Range("F:F"), "إجازة", _ Me.Range("E:E"), ">=" & DateSerial(Year(dCell.Offset(0, -1).Value), Month(dCell.Offset(0, -1).Value), 1), _ Me.Range("E:E"), "<=" & WorksheetFunction.EoMonth(dCell.Offset(0, -1).Value, 0)) > 5 Then dCell.Interior.Color = RGB(255, 0, 0) Else dCell.Interior.ColorIndex = -4142 End If Else dCell.Interior.ColorIndex = -4142 End If Next dCell End If Application.EnableEvents = True End Sub الملف اجاز.xlsb

وعليكم السلام ورحمة الله وبركانه العمود c كود Sub CalculateValues() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim colA As Double Dim colB As Double Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow colA = ws.Cells(i, "A").Value colB = ws.Cells(i, "B").Value If colB <= 500 And colA > 3000 Then ws.Cells(i, "C").Value = colA * 1.5 ElseIf colB > 500 And colA > 3000 Then ws.Cells(i, "C").Value = colA * 2.5 ElseIf colB < 500 And colA < 3000 Then ws.Cells(i, "C").Value = 6000 Else ws.Cells(i, "C").Value = "" End If Next i End Sub العمود d معادلة =IF(B1<500; IF(A1>3000; A1*1.5; 6000); IF(A1>3000; A1*2.5; "")) test2025.xlsb

السلام عليكم ورحمة الله وبركانه تم وضع خيار نعم في العمود e لتحديد المرسل اليهم زر لتحديد الكل قي العمود e زر لمسح الكل قي العمود eا اظافة للكود لنجاوز اي رقم لا يملك واتس او لايتمكن من الارسال اليه ليس لدي واتس لاقوم بالتجربة واتساب رسائل المستأجرين-نسخة.xlsm

وعليكم السلام ورحمة الله وبركاته Private Sub Workbook_Open() On Error Resume Next ThisWorkbook.Sheets("الــــــــــــــــوارد ").ScrollArea = "A1:I753" End Sub "A1:I753" هذا النطاق يمكن تعديله وهو المسموح الكتابه به اذا اردت النطبيق على جداول اخرى انسخ ThisWorkbook.Sheets("الــــــــــــــــوارد ").ScrollArea = "A1:I753" والصقه بالكود وغير اسم الصفحة والنطاق سجل.xlsb

السلام عليكم بعد اذن الاساتذة الاكارم معادلة =IF(L10>0;L10&" فدان";"") & IF(AND(L10>0;K10>0);" و ";"") & IF(K10>0;K10&" قيراط";"") & IF(AND(OR(L10>0;K10>0);J10>0);" و ";"") & IF(J10>0;J10&" سهم";"") & IF(AND(OR(L10>0;K10>0;J10>0);I10>0);" و ";"") & IF(I10>0;I10&" م²";"") الملف مساحة.xlsx

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

وعليكم السلام ورحمة الله وبركاته ملف بحنوى على كود و7 طرق عد بالمعادلات اختر ما يناسبك عد الخلايا الرقمية.xlsb

السلام عليكم ورحمة الله وبركاته اكثر من مرة ادخل الى موضوعك عسى ان اقدم شيئا لحل مشكلة الملف ولكن اتركة للاسباب التالية :- زر ترحيل البيانات يعطى خطأ والسبب ارتباطه بملف اخر لا نعلم ما به واسم الملف ("نموذج فلترة ايام الغياب.xlsm") ربما على جهازك لا يظهر الخطأ لان الملف موجود به ولكن لدينا نظهر رسالة الخطأ Set sourceWorkbook = Workbooks.Open(sourcePath) Set destinationWorkbook = Workbooks("نموذج فلترة ايام الغياب.xlsm") الصفحات التي ليس لها علاقة بالطلب كان يجب حذفها والاكواد التي ليس لها علاق كذلك والبيانات بالملف كان ادراج 15 او 20 اسما يكفى بدل من اكثر من 1000 كان الاجدر ان حددت الاسم او رقم الصف لهذه الحالة او ميزنها بلون فمن لديه الوقت للبحث في 1000 اسم وهل هذا الخطأ للكل ام لبعض الحالات راجعت اول اسم والثاني والثالت وجدت الامور منطابقة واذا كانت هناك حالات كان تحديدها او تميزها بلون اخنصارا للوقت في انتظار توضيح طلبك اكثر وسيكون اعضاء المنتدى مستعدين لتقديم المساعدة لك ولغيرك ان شاء الله عذرا ولك كل الاحترام والتقدير

وعليكم السلام ورحمة الله وبركاته ضف هذا السطر للكود wsSource.Cells(i, 1).Resize(1, 14).ClearContents الكود كاملا Sub test() Dim wsSource As Worksheet Dim wsPass As Worksheet Dim lastRow As Long Dim i As Long Dim passRow As Long Dim passCount As Long Dim failRow As Long Dim wsFail As Worksheet Set wsSource = ThisWorkbook.Sheets("Sheet1") Set wsPass = ThisWorkbook.Sheets("Sheet2") lastRow = wsSource.Cells(wsSource.Rows.Count, "a").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "g").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق wsSource.Cells(i, 1).Resize(1, 14).ClearContents passRow = passRow + 2 End If Next i End Sub

السلام عليكم حفظ الصورة + غرض البيانات الخطوات زر تفريغ البيانات تعبئة البيانات ورقم القيد اجباري زر اظافة ومدمج معه تحميل الصورة ويمكن تحميل الصورة من اي ملف على جهاز الكمبيوتر عرض البيانات - البحث بالقيد او بالاسم مع استدعاء الصورة انتهي الملف المنظومة11.xlsm

السلام عليكم بعد اذن الاستاذ عبد الرحيم محاولة عسى ان يكون فيها طلبك الاول وهو حفظ الصورة كود الاظافة وتحميل نم اظافة المطالبة بادخال رقم القيد خطوات العمل تفريغ المحتوبات كنابة رقم القيد نحميل الصورة الاظافة الطلب الثاني متشعب ومرتبط ب sheet4 والذي لا نعلم ما علاقتة بالامر تحياتي حفظ الصورة.xlsm

السلام عليكم ورحمة الله وبركاته قولى متوسطة لاننى جربت ملفك على جهازي وموارد جهازي جيدة وليست جيدة جدا وملفك يعمل بكفاءة على جهازي حيث قمت بملء الاعمدة التي ذكرنها الى الصف 1006 ولم يتجمد وامور الملف 100% ولهذا اعتقدت ان جهازك موارده متوسطة فعذرا ويما ان ملفك يعمل على جهازي بكفاءة فقلت ربما السبب التنسيقات الشرطية او المعادلات والتي عددها اكثر من 28000 الامور كلها توقعات بسبب عدم حدوث اي مشكلة توقف او تجمد الملف معي عن طريق كود ارفقت لك الملف وفيه كود عد المعادلات وكود عد التنسيقات طبعا التنسيقات حاليا صفر لاته تم حذفها اذا كان السبب كثرة المعادلات فالامر يحناج الى تحويلها الى اكواد وللتاكد ان السبب منها قم بنسخ الورقة كلها ثم لصقها كقيم ثم جرب ملفك اذا انتهت المشكلة فالسبب المعادلات لك وافر التقدير والاحترام حسابات محطة النخلة_٠٩٤٩٥١.xlsm

وعليكم السلام ورحمة الله وبركاته اذا كانت مصادر جهازك منوسطة فالتنسيقات الشرطية + كثرة الالوان + المعادلات الكثيرة كفيلة ان تسبب النجمد لملفك شاهد الصورة كم معادلة وكم تنسيق شرطي في مبفك تم حذق التنسيق الشرطى من الورقة باكملها وعمل كود يقوم بتلوين الخلايا السالبة يوجد زر لعمل ذلك تبقى كثرة المعادلات جرب الملف ربما يكون به بعض التحسن حسابات محطة النخلة_٠٩٤٩٥١.xlsm

وعليكم السلام ورحمة الله وبركانه اولا لديك حساب المدة غير دقيق فمثلا 1/1/2024 - 31/12/2024 ليست 12 شهر ينقصها يوم وبكن يمكن اعتبارها 12 شهر 20-3-2024 - 31-12-2024 ليست 9 اشهر و37 يوم كما ورد في ملفك والصحيح 9 اشهر و11 يوم تم عمل كود يقوم بتوزيع المبلغ على عدد الاشهر وفي حالة وجود ايام مع الاشهر يدخلها قي توزيغ الميلغ حالات استنائية مثل حالة 11شهر و30 يوم سينم نوزيعها على 12 شهر هذا حسب قهمى لطلبك وانمنى ان يكون الملف المرفق فيه طلبك الكود Sub توزيع() Dim ws As Worksheet Dim startDate As Range, endDate As Range, amount As Range Dim i As Long, monthsDiff As Integer, extraDays As Integer Dim totalMonths As Integer, monthlyAmount As Double Dim colStart As Integer Range("H7:S12").ClearContents Set ws = ThisWorkbook.Sheets("ورقة1") Set startDate = ws.Range("D7:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row) Set endDate = ws.Range("E7:E" & ws.Cells(ws.Rows.Count, "E").End(xlUp).Row) Set amount = ws.Range("F7:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row) colStart = 8 For i = 1 To startDate.Rows.Count If IsDate(startDate.Cells(i, 1).Value) And IsDate(endDate.Cells(i, 1).Value) Then Dim startDt As Date, endDt As Date startDt = startDate.Cells(i, 1).Value endDt = endDate.Cells(i, 1).Value monthsDiff = DateDiff("m", startDt, endDt) If Day(endDt) < Day(startDt) Then monthsDiff = monthsDiff - 1 extraDays = Day(endDt) + (Day(DateSerial(Year(endDt), Month(endDt), 0)) - Day(startDt)) Else extraDays = Day(endDt) - Day(startDt) End If If extraDays >= 30 Then monthsDiff = monthsDiff + 1 End If If IsNumeric(amount.Cells(i, 1).Value) And amount.Cells(i, 1).Value > 0 Then If monthsDiff > 0 Then monthlyAmount = amount.Cells(i, 1).Value / monthsDiff Dim j As Integer For j = 0 To monthsDiff - 1 ws.Cells(i + 6, colStart + j).Value = monthlyAmount Next j Else ws.Cells(i + 6, colStart).Value = "" End If Else ws.Cells(i + 6, colStart).Value = "" End If Else ws.Cells(i + 6, colStart).Value = "" End If Next i End Sub جدول توزيع الاقساط.xlsm