نجوم المشاركات

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

تمام .. شكراً جزيلاً

جميع الإجابات صحيحة .. وكل حالة لها حكمها .. ولا نهاية للإبداع 😊👌

نعم معك قلبا وقالبا ، ولكن للضرورات احكام هنا مربط الفرس .. بعضهم يريد لكل عملية ترقيما خاصا يميزها .. وايضا يريد نوع الحقل نصي بحيث تكون البادئة حرف وموضوع الاستاذ جعفر مناسب جدا لمثل هذه الحالاات .. ولكني _ واتحدث عن نفسي_ : لا انكر ان البرمجة لا يقف امامها شيء .. ويمكن تحقيق ما اجمع الكل على استحالته ، ولكني لا احب كثرة العمليات البرمجية وما تستصحبه من ادوات ، لاستخراج نتيجة هي قريبة جدا مني .. ناهيك فيما لو كان نوع حقول الترقيم نصية .. طبعا ستزيد المعالجة . يوجد طريقة سهلة بدائية تستفيد من الترقيم التلقائي ولا تعتمده ، وتصلح للترقيم الخاص سواء كان نوع الحقل رقميا او نصيا وهي عمل حقل ترقيم يتم اضافة الترقيم التلقائي اليه عند كل عملية مثلا تكون القيمة الافتراضية للحقل 1000 أو A000 ستكون النتيجة في السجل الأول 1001 او A001 وستتزايد القيمة في السجلات التالية تبعا لقيمة الترقيم التلقائي . شايب راسه ناشف .. عندنا مثل يقول .. كلٍ بعقله راضي الا ماله لا ...

وعليكم السلام ورحمة الله وبركانه اولا لديك حساب المدة غير دقيق فمثلا 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

الموضوع بسيط جدا .. في حدث عند الإغلاق لنماذج الإدخال أو عند زر الرجوع للشاشة الرئيسية ضع هذا الكود وغير أسماء مربعات النص التي بها عدادات الأرقام : On Error Resume Next [Forms]![frm_basic]![TxtBox1].Requery ' تحديث العداد الأول [Forms]![frm_basic]![TxtBox2].Requery ' تحديث العداد الثاني [Forms]![frm_basic]![TxtBox3].Requery ' تحديث العداد الثالث

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

عند الضغط على الصف الأول بالفورم الرئيسي . Docmd.Close Docmd.OpenForm "فورم الصف الأول" عند الانتهاء من العمل بفورم الصف الأول وعند زر الرجوع للشاشة الرئيسية . Docmd.Close Docmd.OpenForm "الفورم الرئيسي"

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي من المصنف الرئيسي وتحديث ملفات الإدارة دفعة واحدة بدون فتحها او تغيير تنسيقها يكفي وضعها في نفس مسار المصنف بحيث يتم تحديث البيانات عند التحقق من عدم وجود الرقم التأميني مسبقا على ملف الإدارة الهدف وتحديث عمود (م) وإظافة تاريخ التحديث في عمود ( تاريخ دخول القسم) Option Explicit Sub Departments_update() Dim WB As Workbook, destWB As Workbook, srcWS As Worksheet, destWS As Worksheet, _ iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, _ tmp As String, n As String, WSname As String, ShArr As Variant, j As Boolean, _ Updated As Boolean, nameFile As String, cell As Range, result As Boolean ShArr = Array("المستحقين", "احياء", "التفتيش", "اخرى") Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False result = False Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual Application.EnableEvents = False: Application.DisplayAlerts = False Set WB = ThisWorkbook For Each srcWS In WB.Worksheets If Not IsError(Application.Match(srcWS.Name, ShArr, 0)) Then WSname = srcWS.Name nameFile = WB.Path & "\" & WSname & ".xls" If Dir(nameFile) <> "" Then result = True Set destWB = Workbooks.Open(nameFile) Set destWS = destWB.Worksheets(WSname) If Not destWS Is Nothing Then For iRow = 7 To srcWS.Cells(srcWS.Rows.Count, "R").End(xlUp).Row n = srcWS.Cells(iRow, "R").Value If InStr(1, n, WSname, vbTextCompare) > 0 And n <> "" Then tmp = srcWS.Cells(iRow, "E").Value j = False lastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row For Each cell In destWS.Range("E7:E" & lastRow) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = srcWS.Range(srcWS.Cells(iRow, 3), srcWS.Cells(iRow, 27)) dstRng = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 destWS.Cells(dstRng, "C").Resize(, 25).Value = Rng.Value destWS.Cells(dstRng, "D").Value = Date destWS.Cells(dstRng, "B").Formula = Cnt Updated = True End If End If Next iRow destWB.Close SaveChanges:=True Else destWB.Close SaveChanges:=False End If Set destWB = Nothing Set destWS = Nothing End If End If Next srcWS If result Then MsgBox IIf(Updated, "تم تحديث البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Else MsgBox "لم يتم العثور على أي ملفات خاصة بالإدارات", vbExclamation, "تنبيه" End If Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True: Application.DisplayAlerts = True Set WB = Nothing: Set srcWS = Nothing: Set Rng = Nothing: Set cell = Nothing End Sub ملفات الإدارة.rar ترحيل الصفوف مع عدم التكرار.rar

استاذى الجليل و معلمى القدير و والدى الحبيب فضلا وكرما قم بتجربة المرفق التالى اعتبر انها واجهة امامية وهذه هى المرة الاولى التى تستورد اليها الجدوال التى تريد من القاعدة او القواعد الخلفية ان تعددت من النموذج المعد لذلك قبل التجربة لا يوجد اى جداول بعد تجربتك انظر الى الجدول الجديد المحلى والذى سوف يتم انشاءه تلقائيا وقم بفتحه وفحص اسماء الحقول وعناوينها وتوصيفها والبيانات بداخلها ومعه باقى الجداول المرتبطه اعتذر بشدة لم انتبه انه قمت بوضع المشاركة الاخيــــرة بدون المرفق ImportLinkedTableManage.accdb

سلام عليكم اليك مايضاف الى الماكرو لتسريع تنفيذه تجده في المرفق للامانة هذا من اعمال المنتدى جزاهم الله خيرا لي سؤال الى الاستاذ ابو مروان اين يضع ذاك الماكرو لتسريع تنفيذ الماكرو.xlsx