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

ايضا انا استعجلت في الرد فهو قد عالج مسألة التكرار بنفس الطريقة التي بينتها .. ولكني لم انتبه لتحديثه

معلمنا الفاضل هذا من حسن حظي بلا شك لا شك أن ألأستاذ @Barna أنتج عمل جميل وذكي ، إلا أن فكرتي كانت بتوسيع المجال ليس إلا

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

ومشاركة مع أستاذنا ابو خليل فصل العدد الكسري.accdb

أستاذنا القدير @Foksh أستاذنا القدير @Barna أستاذنا القدير @ابوخليل عجزت الكلمات.. تلعثم اللسان.. توقف الكلام.. تراجع البنان.. واحتار الفكر في جمال العطاء .. بأفكاركم الرائعة .. والسبق النبيل.. الحقيقة أنا اليوم السعيد بكم.. وبمعرفتكم وعطائكم،، فإني أقف خجلا من كرمكم العامر.. ولكن خير الجزاء صدق الدعاء والسعي لنشر هذه الأفكار لتكون محط زاد مستمر لأصحاب الفضل من أمثالكم.. شكر الله لكم ورحم والديكم وبلغكم شهر الخيرات وأنتم في أحسن حال وأفضل صحة وخير وعافية..

من الافضل جعل قيمة القائمة المنسدلة دور ثان فقط بدون له او لها واستخدام الكود التالي Sub Filter_and_copy_with_condition() Dim d, j Dim Search As Range, clé As String, IRow As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim F As Worksheet: Set F = Worksheets("saad") d = 9: j = 16: clé = "*" & F.[k1] IRow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row With Application .Calculation = xlManual .ScreenUpdating = False If Len([k1].Value) = 0 Then: Exit Sub Set Search = WS.Range("U16:U" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub F.Range("C10:O" & Rows.Count).ClearContents Do Until IsEmpty(WS.Range("U" & j)) If WS.Range("U" & j) Like clé Then d = d + 1 F.Cells(d, 3).Value = WS.Cells(j, 3).Value F.Cells(d, 5).Value = WS.Cells(j, 5).Value F.Cells(d, 6).Value = WS.Cells(j, 6).Value F.Cells(d, 8).Value = WS.Cells(j, 10).Value F.Cells(d, 10).Value = WS.Cells(j, 12).Value F.Cells(d, 11).Value = WS.Cells(j, 13).Value F.Cells(d, 12).Value = WS.Cells(j, 16).Value F.Cells(d, 13).Value = WS.Cells(j, 17).Value F.Cells(d, 14).Value = WS.Cells(j, 18).Value F.Cells(d, 15).Value = WS.Cells(j, 21).Value End If j = j + 1 Loop .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub مصطفي V3.xlsb

تفضل ووافينا بالنتيجة Sub Filter_and_copy_with_condition() Dim Rng As Range, Search As Range Dim Col As Variant, a As Variant, MyRng As Variant, clé As Variant Dim i As Long, F As Long, Cpt As Long, Lastrow As Long, Irow As Long, ColStar As Long Dim WS As Worksheet: Set WS = Worksheets("control4") Dim desWS As Worksheet: Set desWS = Worksheets("saad") clé = desWS.[k1]: ColStar = 10 'نطاق البيانات Lastrow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = WS.Range("C16:U" & Lastrow) Col = Rng.Value2 If Len([k1].Value) = 0 Then: Exit Sub With desWS Set Search = WS.Range("U16:U" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole) If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub Application.ScreenUpdating = False ' تخزين البيانات القديمة Irow = desWS.Columns("C:AT").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For Cpt = ColStar To Irow MyRng = desWS.Range("P10:AT" & Cpt).Value Next ' افراغ البيانات السابقة desWS.Range("C10:O" & Cpt).ClearContents ReDim a(1 To UBound(Col), 1 To UBound(Col, 2)) End With For i = 1 To UBound(Col) ' عند تحقق الشرط If Col(i, 19) = clé Then F = F + 1 a(F, 1) = Col(i, 1): a(F, 3) = Col(i, 3): a(F, 4) = Col(i, 4) a(F, 6) = Col(i, 8): a(F, 8) = Col(i, 10): a(F, 9) = Col(i, 11) a(F, 10) = Col(i, 14): a(F, 11) = Col(i, 15): a(F, 12) = Col(i, 16): a(F, 13) = Col(i, 19) End If Next i [C10].Resize(F, UBound(a, 2)).Value2 = a For Cpt = ColStar To Irow desWS.Range("P10:AT" & Cpt).Value = MyRng Next Application.ScreenUpdating = True End Sub وفي حدث ورقة saad ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("k1")) Is Nothing Then Call Filter_and_copy_with_condition End If End Sub مصطفي V2.xlsb

وعليكم السلام ورحمة الله وبركاته تفضل حل متواضع بالمعادلات ويمكن التنفيذ للحل بالأكواد يمكن البحث داخل المنتدى عن استدعاء وترحيل البيانات نموذج أوفيسنا 002.xlsm

مضبوط تسلم إيدك .. وجزاك الله خيراً . وفي إنتظار التعليق علي الكود إن أمكن .. ونفع الله بك دائماً

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

يلزمك استخدام مكتبة اوفيس١٦ او ١٤ حسب اصدار الأوفيس لديك ليتم فتح مربع حوار اختيار ملف مثلاً.

وجهة نظر قوية 😁

أخي الكريم @عبدالقدوس48 هل تتوقع ان من يجيب هو من يضع الامثلة والمرفق ..... ام السائل هو من يزودنا بالمرفق للتطبيق عليه بعد دراسة طريقته في البرنامج ووضع الحل المناسب لمرفقه .... بارك الله فيك

وعليكم السلام ورحمة الله وبركاته ... منذ ان شاهدت الموضوع وانا افكر في هذا الاسلوب ... يعني انا لوكنت موظف وعارف اني متأخر .... لن احضر الا في الساعة الاخيرة من الدوام ...

أشكرك شكراً جزيلاً وأعتذر عن التأخر في الرد .. وأتمني لو بالإمكان أن تفيدني بالتعليق علي كل جزء من الكود لأتمكن من معرفة ماذا يفعل كل جزء منه .. وشكراً مره أخري

جميل

تفضل استاذ @SAROOK التعديل حسب طلبك بعد تدارك ملاحظاتك . 2-الغياب والتاخير.rar

على السريع لفصل الرقم الصحيح Expr1: Left([text1],InStr([text1],".")-1) لفصل الكسر Expr2: "0" & "." & Right([text1],InStr([text1],"."))

تفضل add attachment.accdb

والله ما اعرف اشكرك ازاي يا أستاذ محمد ربنا يبارك فيك ويجعله في ميزان حسناتك وشكرا جزيلا لكل أعضاء المنتدي الكرام

السلام عليكم توافقت الكتابة مع مشاركة اخي فادي الأخيرة انا ارى ان حل اخونا البرناوي نموذجي .. ولمعالجة التكرار يتم حذف البيانات من الجدول قبل كل امر على النحو التالي Private Sub أمر0_Click() DoCmd.SetWarnings False DoCmd.RunSQL "DELETE TEMP_DATE.*, * FROM TEMP_DATE" DoCmd.SetWarnings True Call InsertYears End Sub 3الأعوام بين تاريخين.accdb

هدفي والحمد لله تم تحقيقه تم والحمد لله تعميم الفكرة بحيث يمكن استعمالها في أكثر من جدول ، وحسب الحاجة دون تقييد . أولا انشاء المديول العام :- Function CreateYearsRecords(sourceTableName As String, employeeFieldName As String, startDateFieldName As String, _ endDateFieldName As String, targetTableName As String, targetEmployeeFieldName As String, targetStartDateFieldName As String, targetEndDateFieldName As String, targetYearsFieldName As String) Dim sourceRS As DAO.Recordset Dim targetRS As DAO.Recordset Dim recordStartDate As Date Dim recordEndDate As Date Dim currentYear As Integer DoCmd.SetWarnings False DoCmd.RunSQL "DELETE " & targetTableName & ".* FROM " & targetTableName & ";" DoCmd.SetWarnings True Set sourceRS = CurrentDb.OpenRecordset(sourceTableName) Set targetRS = CurrentDb.OpenRecordset(targetTableName) Do Until sourceRS.EOF recordStartDate = sourceRS.Fields(startDateFieldName) recordEndDate = sourceRS.Fields(endDateFieldName) For currentYear = Year(recordStartDate) To Year(recordEndDate) targetRS.AddNew targetRS.Fields(targetEmployeeFieldName) = sourceRS.Fields(employeeFieldName) targetRS.Fields(targetStartDateFieldName) = sourceRS.Fields(startDateFieldName) targetRS.Fields(targetEndDateFieldName) = sourceRS.Fields(endDateFieldName) targetRS.Fields(targetYearsFieldName) = CStr(currentYear) targetRS.Update Next currentYear sourceRS.MoveNext Loop sourceRS.Close targetRS.Close Set sourceRS = Nothing Set targetRS = Nothing End Function ثانياً يمكن استدعاء الدالة كما يلي :- Call CreateYearsRecords("date1", "t1", "t2", "t3", "TEMP_DATE", "EmployeeName", "StartDate", "EndDate", "Years") بحيث يتم ادراج البيانات في جدول قابل للتغيير واسماء الحقول فيه أيضاً . Get Date.accdb

جزيل الشكر لكم اخوتي حل آخر باستخدام بور كويري المصنف1.xlsx

ما شاء الله عليك انت صخ ولكن يبدو أنك أغفلت أن النطاقات لابد وأن تكون متساوية داخل الصيغة =SUMIFS(E4:E87,D4:D87,"لارج",B4:B87,"="&(TODAY())) حضرتك وضعت =SUMIFS(E4:E87,D4:D11,"لارج",B4:B87,"="&(TODAY())) وان شاء الله هتشتغل معاك

يمكن لكن كدا كل جزء ها يكون في خلية ها تستبدل "Y" ب "YM" علشان تظهر الشهر و "MD" علشان الأيام

تعتذر وانت صاحب الفضل.. هذا من طيب المنبع وحسن التربية وجمال الأخلاق فرحم الله رحما حملك وأبا رباك.. والعلم رحم بين أهله.. والحمد لله الفائدة حاصلة بدءا بجهودك الرائعة وبمشاركة أستاذنا @Barna وإنما التكامل هنا للإثراء بجمال المعلومات واختيار أفضل الطرق.. لتكون لنا ولمن بحث وكتب ومر على هذا المنتدى الرائع.. وهذا الأثر الذي يبقى نفعه ويعم خيره.. شكرا لك @Foksh شكرًا لك @Barna قدمتم فأجدتم وأحسنتم نفعا وتكاملا..

اعتذر منك اخوي على تجاربي التي تكاد تلمس نجاح فكرتك ، اقوم بقراءة الكود نظرياً لعدم وجودي قرب الكمبيوتر في الوقت الحالي سأقوم بتنفيذ الفكرة غداً سعياً لانجاح الفكرة ، فليس من طبعي الوقوف عند تجربة غير ناجحة والاستسلام لها. 🤗

بارك الله لك

استخدم المعادلة التالية باعتبار أن الرقم القومي في الخلية B3 =DATEDIF(DATE(IF(LEFT(B3;1)*1=3;20;19)&MID(B3;2;2);MID(B3;4;2);MID(B3;6;2));TODAY();"y") حيث يتم تقسيم الرقم القومي إلى شهر وسنة وأيام وبعدها يتم طرحه من اليوم الحالي today واظهار الناتج بالسنة y

ما شاء الله عليك أخي موسى، بارك الله فيك وجار تجربة النسخة، رفع الله قدرك وزادك الله علما

سلمت يمناك حبيبنا الغالي 😄🌹 في ميزان حسناتك يا رب 😊 تم دمج الرابط مع المشاركة الأولى 😉👌🏻

جزاك الله خير وبارك فيك @عصام مسعد ممكن تشرح القانون كيف يتم خصم الضريبه علي الدخل

جزاك اللله كل خير اخي

بارك الله فيك وجعله الله في ميزان حسناتك

هذا كل ما استطيع تقديمه اخى الكريم