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

وعليكم السلام-كان عليك لزاما قبل رفع المشاركة استخدام خاصية البحث فى المنتدى ,فقد تكرر هذا الموضوع مرات عديدة ومنها : https://www.officena.net/ib/topic/94016-دالة-استخراج-تاريخ-الميلاد-والنوع-والمحافظة-من-الرقم-القومي/?tab=comments#comment-583042

تفضل Final Indeminity1.xlsx

تفضل قائمة 1منسدله.xls

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

وعليكم السلام-تفضل Test vlookup1.xlsx

وعليكم السلام -تفضل استاذنا الكريم ياسر خليل ابو البراء على تناول هذا الموضوع من قبل اعتذر منك استاذى الكريم ياسر فليس هناك امكانية فى وضع الرابط هنا ولكن تم وضعه داخل الملف لكى تعم الإستفادة للجميع للإطلاع على هذا الموضوع والإستفادة منه ان شاء الله حماية المعادلات في كل أوراق العمل Protect Formulas In All Sheets.xlsm

أحسنت استاذ مجدى عمل رائع جعله الله فى ميزان حسناتك

أحسنت استاذ مجدى بارك الله فيك

اتفضل اخي الكريم Dim Rs, RsFile As Recordset Set Rs = CurrentDb.OpenRecordset("اسم الجدول") Rs.MoveFirst Do While Not Rs.EOF If IsNull(DLookup("ID_User", "Users", "ID_User='" & [ID_User] & "'")) Then Rs![ID_User] = [ID_User] Rs![ID_Group] = [ID_Group] Rs![IAM] = [IAM] Rs![BIRTHDATE] = [BIRTHDATE] Rs![Email] = [Email] Rs![PHONE] = [PHONE] Rs![ImagePath] = [ImagePath] Else If Rs![ID_User] = [ID_User] Then Rs.Edit Rs![ID_Group] = [ID_Group] Rs![IAM] = [IAM] Rs![BIRTHDATE] = [BIRTHDATE] Rs![Email] = [Email] Rs![PHONE] = [PHONE] Rs![ImagePath] = [ImagePath] Rs.Update End If End If Rs.Update Rs.MoveNext Loop Rs.Close

طيب حضرتك اتفضل جرب Prog302.mdb

طريقة اخرى Count Down WaitSeconds.accdb

فورم حذف البيانات المسجلة فيديو9 الفيديو

جرب المرفق ترحيل خلايا محددة لاخري محددة في شيتات مختلفة.xlsm

شرح كيفية عمل شاشة دخول للاكسل بصورة جمالية الفيديو

الاداة لا علاقة لها بقاعدتك اصلا ولا تصدر اى شئ منها انما تقوم بفتحها وتحدد منها مكان قاعدتك او اى قاعدة تريدها لتمكن او تعطل عمل زر الشيفت لها وتختر اما تفعيل الشيقت او ايقافه

بخصوص موضوع اغلاق القاعدة بعدم تفعيل الشيفت اتفضل لتطبيق او تعطيل مفتاح الشيفت لاى قاعدة بيانات من خلال هذه الاداة وللعلم لست المصمم لهذه الاداة فقط قمت ببعض التطويرات التى تجعلها تتماشي مع جميع الاصدارات القديمة والحديثة تمكين الشفت (2020).accdb

السلام عليكم اولا للعلم لا يوجد شئ اسمه حماية مطلقة فدائما الحماية هى مسئلة نسبية ومسأله وقت لذلك نصيحتى ولوجه الله لا تشغل بالك كثيرا بهذا الموضوع كما انصحك نصيحة أخرى ان وجود الازرار فى الواجهة والتى تحمل اسم Management , Admin وخاصة عند الضغط عليها وطلب كلمة المرور فإنها حتما سوف تثير فضول المتطفلين فى محاولات شتى انت فى غنى عنها ممكن بشكل أو بأخر تنفيذ ما تريد بدون ان تقدم للعابثين ما يثير فضولهم

اتفضل 120 (1).accdb

سبحان الله هذا رزقك خطرت على بالى فكرة ونجحت اتفضل Count Down WaitSeconds.accdb

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

أحسنت استاذ مجدى بارك الله فيك

بارك الله فيك وزادك الله من فضله

كان فيه خطا في المرفق السابق حمل التعديل Prog302 (1)2.mdb

طيب انا مش فاهم كويس ممكن سؤال لو النموذج الفرعى بدون اى سجلات نهائيا على تريد اغلاقها ؟؟؟

مشاركة مع اخي ابا جودي بعد اذنه اتفضل Prog302.mdb

بسيطة يا سيدى انتظرنى

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

هو واضح ان المعيار السابق فيه خطا لانه اكبر او يساوي +1 لابد يحصل فارق رقم طالما العدد فردي وانا جربت وعدلت المعيار واشتغل تمام غلطت @ابا جودى بالف

المعيار للقائمة ب >(DCount("[ترقيم تلقائي]";"جدول1")/2) وانتهت المشكلة

فكرة جميلة

صباح النور وعطور الزهور على معلمى الجليل استاذى الكريم الفاضل الاستاذ @essam rabea صاحى اصلى وما جالى نوم دخلت للمنتدى جزاكم الله خيرا استاذى الجليل على دعواتكم الطيبة أوووف والله لم انتبه اسف جدا جدا حاضر استاذى لن أشارك كثيرا بعد ذلك سانتظر ليكون ردى بعد اساتذتى ان تفضل الله تعالى بأفكار مختلفة من الان كل الزبائن لكم ولكن سوف اقتسم معكم الاجر

الشكر الموصول لك اخي العزيز العيدروس اللهم زدك علما وبارك لك في عملك ورزقك على مابذلته في مساعدتي

علكم السلام هذه تجربة متواضعة يمكنك العمل عليها ان اعجبتك التنقل بين الصفحات.xlsm

هذا رزقي وابداعك استاذي ابا جودي شكرا كتير الك

للرفع

اتفضل فتح نموذج اكثر من مرة.accdb

احسنت اخي ابو عارف بارك الله فيك

السلام عليكم و رحمة الله و بركاته أخي العزيز أبا جودي : اولا اشكرك على ما تقدمه لاخوانك في المنتدى ثانيا بعد اطلاع على البرنامج وجدت البرنامج يعمل بكفائة و ماشاء الله عليك و في نفس وقت حبيت عرض اقتراح اختصار وحدة نمطية modConverter من: Public Function ToUniCode(myData As String) myData = Replace(myData, ChrW(1569), "ChrW(1569)") myData = Replace(myData, ChrW(1570), "ChrW(1570)") myData = Replace(myData, ChrW(1571), "ChrW(1571)") myData = Replace(myData, ChrW(1572), "ChrW(1572)") myData = Replace(myData, ChrW(1573), "ChrW(1573)") myData = Replace(myData, ChrW(1574), "ChrW(1574)") myData = Replace(myData, ChrW(1575), "ChrW(1575)") myData = Replace(myData, ChrW(1576), "ChrW(1576)") myData = Replace(myData, ChrW(1577), "ChrW(1577)") myData = Replace(myData, ChrW(1578), "ChrW(1578)") myData = Replace(myData, ChrW(1579), "ChrW(1579)") myData = Replace(myData, ChrW(1580), "ChrW(1580)") myData = Replace(myData, ChrW(1581), "ChrW(1581)") myData = Replace(myData, ChrW(1582), "ChrW(1582)") myData = Replace(myData, ChrW(1583), "ChrW(1583)") myData = Replace(myData, ChrW(1584), "ChrW(1584)") myData = Replace(myData, ChrW(1585), "ChrW(1585)") myData = Replace(myData, ChrW(1586), "ChrW(1586)") myData = Replace(myData, ChrW(1587), "ChrW(1587)") myData = Replace(myData, ChrW(1588), "ChrW(1588)") myData = Replace(myData, ChrW(1589), "ChrW(1589)") myData = Replace(myData, ChrW(1590), "ChrW(1590)") myData = Replace(myData, ChrW(1591), "ChrW(1591)") myData = Replace(myData, ChrW(1592), "ChrW(1592)") myData = Replace(myData, ChrW(1593), "ChrW(1593)") myData = Replace(myData, ChrW(1594), "ChrW(1594)") myData = Replace(myData, ChrW(1600), "ChrW(1600)") myData = Replace(myData, ChrW(1601), "ChrW(1601)") myData = Replace(myData, ChrW(1602), "ChrW(1602)") myData = Replace(myData, ChrW(1603), "ChrW(1603)") myData = Replace(myData, ChrW(1604), "ChrW(1604)") myData = Replace(myData, ChrW(1605), "ChrW(1605)") myData = Replace(myData, ChrW(1606), "ChrW(1606)") myData = Replace(myData, ChrW(1607), "ChrW(1607)") myData = Replace(myData, ChrW(1608), "ChrW(1608)") myData = Replace(myData, ChrW(1609), "ChrW(1609)") myData = Replace(myData, ChrW(1610), "ChrW(1610)") myData = Replace(myData, ChrW(32), "ChrW(32)") ToUniCode = Replace(myData, ")ChrW", ") & ChrW") End Function Public Function ToArabic(myData As String) myData = Replace(myData, "ChrW(1569)", ChrW(1569)) myData = Replace(myData, "ChrW(1570)", ChrW(1570)) myData = Replace(myData, "ChrW(1571)", ChrW(1571)) myData = Replace(myData, "ChrW(1572)", ChrW(1572)) myData = Replace(myData, "ChrW(1573)", ChrW(1573)) myData = Replace(myData, "ChrW(1574)", ChrW(1574)) myData = Replace(myData, "ChrW(1575)", ChrW(1575)) myData = Replace(myData, "ChrW(1576)", ChrW(1576)) myData = Replace(myData, "ChrW(1577)", ChrW(1577)) myData = Replace(myData, "ChrW(1578)", ChrW(1578)) myData = Replace(myData, "ChrW(1579)", ChrW(1579)) myData = Replace(myData, "ChrW(1580)", ChrW(1580)) myData = Replace(myData, "ChrW(1581)", ChrW(1581)) myData = Replace(myData, "ChrW(1582)", ChrW(1582)) myData = Replace(myData, "ChrW(1583)", ChrW(1583)) myData = Replace(myData, "ChrW(1584)", ChrW(1584)) myData = Replace(myData, "ChrW(1585)", ChrW(1585)) myData = Replace(myData, "ChrW(1586)", ChrW(1586)) myData = Replace(myData, "ChrW(1587)", ChrW(1587)) myData = Replace(myData, "ChrW(1588)", ChrW(1588)) myData = Replace(myData, "ChrW(1589)", ChrW(1589)) myData = Replace(myData, "ChrW(1590)", ChrW(1590)) myData = Replace(myData, "ChrW(1591)", ChrW(1591)) myData = Replace(myData, "ChrW(1592)", ChrW(1592)) myData = Replace(myData, "ChrW(1593)", ChrW(1593)) myData = Replace(myData, "ChrW(1594)", ChrW(1594)) myData = Replace(myData, "ChrW(1600)", ChrW(1600)) myData = Replace(myData, "ChrW(1601)", ChrW(1601)) myData = Replace(myData, "ChrW(1602)", ChrW(1602)) myData = Replace(myData, "ChrW(1603)", ChrW(1603)) myData = Replace(myData, "ChrW(1604)", ChrW(1604)) myData = Replace(myData, "ChrW(1605)", ChrW(1605)) myData = Replace(myData, "ChrW(1606)", ChrW(1606)) myData = Replace(myData, "ChrW(1607)", ChrW(1607)) myData = Replace(myData, "ChrW(1608)", ChrW(1608)) myData = Replace(myData, "ChrW(1609)", ChrW(1609)) myData = Replace(myData, "ChrW(1610)", ChrW(1610)) myData = Replace(myData, "ChrW(32)", ChrW(32)) ToArabic = myData 'ToArabic = Replace(myData, ") & ChrW", ")ChrW") End Function اي تعديل فنكشن ToUnicode و حذف فنكشن ToArabic نهائي : Public Function ToUniCode(myData As String) Dim dgt As String Dim Newstring As String Dim i For i = 1 To Len(myData) dgt = AscW(Mid(myData, (i), 1)) Newstring = Newstring & " Chrw (" & Chr(34) & dgt & Chr(34) & ") & " Next i Newstring = Left(Newstring, (Len(Newstring) - 2)) ToUniCode = Newstring End Function و تغير في الكود الزر BtnToArabic كبديل فنكشن ToArabic الي: On Error GoTo Err_Handler Me.frmToArabic!txtArabic.ControlSource = "=" & Me.frmToArabic!txtUnicode Exit_Handler: Exit Sub Err_Handler: MsgBox Err.Description Resume Exit_Handler و اخيرا اتمنى لك صحة وتوفيق

كلام من ذهب تسلم استاذنا وحبيبنا @رمهان

تم التعديل على الملف السابق بتعميم المعادلة لكى تعمل على كل الأعمدة وهذه هى المعادلة =COUNTIF(D$7:D7,D7)>1

بارك الله فيك وزادك الله من فضله

شاهذ هذا الفيديو https://www.youtube.com/watch?v=SQHJuc-AdAM

جرب هذا الملف الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$H$1" And Target.Count = 1 Then sort_please End If Application.EnableEvents = True End Sub '========================= Sub sort_please() Dim Rg As Range Dim s Dim ro%: ro = Range("b2", Range("b1").End(4)).Rows.Count + 1 Set Rg = Range("a1").Resize(ro, 3) Rg.Sort key1:=Cells(1, Range("h1")), _ Order1:=IIf(Range("h1") = 2, 2, 1), Header:=2 s = "Row( 1:" & ro & ")" Range("a1").Resize(ro) = Evaluate(s) End Sub الملف مرفق 0Choose_Num_sort.xlsm

شكرا جزيلا أستاذ @سليم حاصبيا علي ذوقك وتعاونك

جرب هذا الماكرو Option Explicit Private Fltr_range As Range, I_range As Range Private EHsaa As Worksheet, Tasj As Worksheet Private lr_EHsaa%, lr_Tasj, m% '=============================== Sub my_filter() Set EHsaa = Sheets("احصاء الغيابات") Set Tasj = Sheets("تسجيل الغيابات") lr_EHsaa = EHsaa.Cells(Rows.Count, 2).End(3).Row lr_Tasj = Tasj.Cells(Rows.Count, 2).End(3).Row Set Fltr_range = Tasj.Range("B6:E" & lr_Tasj) Set I_range = EHsaa.Range("T1:T6") lr_EHsaa = IIf(lr_EHsaa = 3, 4, lr_EHsaa + 1) Dim i% For i = 1 To I_range.Rows.Count Call Filter_FOR_Me(Fltr_range, 3, EHsaa.Range("T" & i)) Next EHsaa.Range("b3").Select Application.CutCopyMode = False Fltr_range.AutoFilter End Sub '============================================= Sub Filter_FOR_Me(rg As Range, n, St) rg.AutoFilter , field:=n, Criteria1:=St rg.Offset(1).Resize(rg.Rows.Count - 1).Copy EHsaa.Range("B" & lr_EHsaa).PasteSpecial xlValues m = EHsaa.Cells(Rows.Count, 2).End(3).Row + 1 lr_EHsaa = m + 1 End Sub الملف مرفق Abscence.xlsm

تفضل لك ما طلبت تنسيق شرطى بشرطين.xlsx

بالفعل تم التجربه والملف رائع جدا تسلم ايديك وتستاهل اكثر من ذلك ( اللهم إني أستودعتك شخص بعيد عن عيني قريب من قلبي اللهم إني أستودعتك راحة باله وسعادته وضحكته بحجم سمائك السابعه اللهم أرزق قلبه الراحة والطمأنينة والفرح والامان اللهم اجعل له بكل خطوة يخطيها في حياته توفيق ونجاح وتيسير اللهم قل لأمنياته وأحلامه كن فتكون )

وعليكم السلام-تفضل هذا الكود Option Explicit Sub opening_multiple_file() Dim i As Integer With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Clear .Filters.Add "Excel Files", "*.xls*" If .Show = True Then For i = 1 To .SelectedItems.Count Workbooks.Open .SelectedItems(i) Next i End If End With End Sub

كيف لا يعمل وهو به بيانات

وندز 7 يسير تستطيع التنفيذ من مربع التشغيل ولكن انتبه ! يجب اولا خفض امان وندز اذهب لوحة التحكم ثم الى المستخدمين / التحكم وتغيير حساب مستخدم ثم خفض الامان الى الحد الادنى كما في الصورة هذا الامر ينطبق ايضا على وندز 8