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

وعليكم السلام ورحمة الله وبركانه اضطررت الى تعديل الجدول قليلا في صفحة جدوال الشرائح الكود Sub CalculateRanges() Dim wsClients As Worksheet Dim wsRanges As Worksheet Dim lastRowClients As Long Dim i As Long, j As Long, k As Long Dim count As Long Dim total As Double Dim depositValue As Double Dim rangeStart As Double Dim rangeEnd As Double Dim ranges As Variant Dim colIndex As Variant Dim infiniteRows As Variant Set wsClients = ThisWorkbook.Sheets("العملاء") Set wsRanges = ThisWorkbook.Sheets("جدوال الشرائح") lastRowClients = wsClients.Cells(wsClients.Rows.count, 1).End(xlUp).Row ranges = Array(Array(3, 7, 3), Array(10, 14, 4), Array(17, 21, 5), Array(24, 28, 6), Array(31, 35, 7)) infiniteRows = Array(7, 14, 21, 28, 35) For k = LBound(ranges) To UBound(ranges) wsRanges.Range("D" & ranges(k)(0) & ":F" & ranges(k)(1)).ClearContents For i = ranges(k)(0) To ranges(k)(1) rangeStart = wsRanges.Cells(i, "B").Value If IsInArray(i, infiniteRows) Then rangeEnd = Application.WorksheetFunction.Large(wsClients.Range("C2:C" & lastRowClients), 1) * 10 ' اعتبار القيمة ما لا نهاية Else rangeEnd = wsRanges.Cells(i, "C").Value End If count = 0 total = 0 For j = 2 To lastRowClients depositValue = wsClients.Cells(j, ranges(k)(2)).Value If depositValue >= rangeStart And depositValue <= rangeEnd Then count = count + 1 total = total + depositValue End If Next j wsRanges.Cells(i, "D").Value = count wsRanges.Cells(i, "E").Value = total Next i wsRanges.Cells(ranges(k)(1) + 1, "D").Formula = "=SUM(D" & ranges(k)(0) & ":D" & ranges(k)(1) & ")" wsRanges.Cells(ranges(k)(1) + 1, "E").Formula = "=SUM(E" & ranges(k)(0) & ":E" & ranges(k)(1) & ")" Next k End Sub Function IsInArray(valueToFind As Variant, arr As Variant) As Boolean Dim i As Long For i = LBound(arr) To UBound(arr) If arr(i) = valueToFind Then IsInArray = True Exit Function End If Next i IsInArray = False End Function الملف شرائح.xlsb

الله يحفظك =IF(J15 < 0; "المبلغ ناقص"; "المبلغ كامل") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

وعليكم السلام ورحمة الله وبركاته =IF(J15 < 0; "المبلغ ناقص"; "") اذا كان الرقم بالسالب تظهر كلمة المبلغ ناقص.xlsx

وعليكم السلام ورحمة الله وبركانه الملف ____أرقام الجلوس والمناداة - 2025 الرابع.xlsm

طريقة اخرى بدالة غير مباشرة Function GetHyperlinkAddress(rng As Range) As String On Error Resume Next GetHyperlinkAddress = rng.Hyperlinks(1).Address End Function ثم في العمود M نكتب =GetHyperlinkAddress(I2) لرابط اليوتيوب وفي العمود J نكتب لرابط الفيس =GetHyperlinkAddress(J2) الملف qrcode1.xlsb

وعليكم السلام ورحمة الله وبركاته عن طريق كود الكود يتعامل مع العمود I يمكن تغييره الى عمود اخر بالكود Sub ExtractHyperlinks() Dim ws As Worksheet Dim lastRow As Long Dim cell As Range Dim hyperlinkAddress As String Set ws = ThisWorkbook.Sheets("Sheet1") lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row For Each cell In ws.Range("I2:I" & lastRow) If cell.Hyperlinks.Count > 0 Then hyperlinkAddress = cell.Hyperlinks(1).Address ws.Cells(cell.Row, "M").Value = hyperlinkAddress End If Next cell End Sub الملف qrcode.xlsb

المقصود عند دخول الورقة قائمة الاسماء قي العمود D كلما اضفت اسما او اكثر ولو كان مكررا تجده في القائمة في الخلية وهذا ما يقوم به الكود حاليا عند تغيير الاسم في الخلية I6 نجد مجموع الرواتب في M6 ومجموع السلف في M7 للموظف اذا كانت بياناتك بسيطة فمعادلان اما اذا كانت كبيرة فانصحك بالكود على كل حال اليك الحل عن طريق المعادلات ولك الخيار في استخدام ما يفيدك في عملك DC (1).xlsx

السلام عليكم حسب فهمي لطلبك Jجمع رواتب الموظف ووضعها في M6 وجمع سلفه ووضعها في M7 وذلك حسب الاسم في I6 ان كان كذلك جرب الملف القائمة في I6 يتم تحديثها عند الدخول الى الورقة لوحدها DC (1).xlsb

السلام عليكم اخى الفاضل الاسباب كثيرة منها ربما الإصدارين مثبتان بشكل صحيح وتوجد تعارضات بينهما ربما عدم وجود Microsoft Forms 2.0 Object Library ربما التحديثات التلقائية لأحد الإصدارين إلى تعطيل أو إفساد إعدادات الإصدار الآخر على كل حال ارفاق ملف يقفل باب ربما في انتظار ارفاق ملفك لاصدار 2016 وهو الموجود حاليا على جهازي لك كل الود والاحنرام

السلام عليكم ورحمة الله وبركانه اظافة الى حل استاذنا احمد يوسف جزاه الله خيرا يمكن استخدام كود لاستدعاء اجور الطعام مع الاستحقاق مع اعتماد الخلايا الصفراء حال عدم وجود تاريخ معادلة بشروط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

السلام عليكم ارجو نحديد الاعمار التي تريد عدها هل تعنبر هذه الاعمار من ضمن 30 سنة اكبر من 29 الى اقل من 31 اذ كان كذلك استخدم المعادلة ويمكنك تعديل السن بها =COUNTIFS(E:E; "Female"; J:J; "Giza"; G:G; ">29"; G:G; "<31")