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

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

هههههههه الله يسعدك يبو جودي والله انك عسل

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

لا شكر على واجب وبعدين لا ابداع ولا شئ هذا رزقك وفضل من الله تعالى اولا واخيرا

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

اكثر جمل الاتصال الآمن استخدمها تكون على النحول التالي في رأس موديل الفورم Option Explicit Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Const SW_HIDE As Long = 0 Private Const SW_SHOWNORMAL As Long = 1 الاتصال ( اضف الأيبي + اسم المستخدم + كلمة المرور ) ShellExecute Me.hwnd, "Open", "C:\Windows\System32\mstsc.exe", "/P pinghost=Enter server IP address: '' \\%pinghost% /user:''\username ''", "C:\", SW_SHOWNORMAL اذا استطعت الاتصال و الدخول لسطح المكتب يصير الأمر بسيط فقط بتعديل السطر اعلاه

صباح الخير ياورد ويا كلك ورد شكراً استاذي ابا جودي

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

عليكم السلام اخي ابا جودي نورت الصفحه مرور الخبراء يسعدني وتعليقاتكم جد تفرحني وتفيدني بنسبه للازرار اخي كلامك صحيح 100% انا لقيت اناه وجود الازرار بهادا الشكل اسهل بنسبه لي بما اني جديد في عالم اكسس + انا الوحيد الى جالس اتعلم اكسس واحاول اعمل نمادج بسيطه ع قدي يعني عشان كدا ماعندي خوف من المتطفلين اشكرمرورك الطيف اخي العزيز لاتحرموني من النصح والتوجيه

للرفع

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

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

ربما تقصد مثل ما في المرفق test2.xlsm

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

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

جرب هذا الملف الكود 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 Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$C$1" Then Call filter_me(Range("A3").CurrentRegion, 6, Target.Value) End If Application.EnableEvents = True End Sub '=========================================== Sub Create_dat_val() Rem created By Salim Hasbaya On 17/9/2019 Dim s1 As Worksheet: Set s1 = Sheets("sheet1") Dim ro_n: ro_n = s1.Range("A3").CurrentRegion.Rows.Count Dim i% Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") With s1 For i = 4 To ro_n dict(.Range("F" & i).Value) = "" Next With .Range("c1").Validation .Delete .Add xlValidateList, Formula1:=Join(dict.keys, ",") End With End With dict.RemoveAll End Sub '=========================================== Sub filter_me(rg As Range, n, My_st) Rem created By Salim Hasbaya On 17/9/2019 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData rg.AutoFilter End If rg.AutoFilter field:=n, Criteria1:=My_st End Sub '=========================================== Sub Show_Me_All() Rem created By Salim Hasbaya On 17/9/2019 If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData Range("A3").CurrentRegion.AutoFilter End If End Sub ثانياً الملف Filter_By_Select.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

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

تفضل بحث1.xlsm

أاى عمود للتاريخ تريد العمل عليه؟

تفضل لك كل ما طلبت ht.xlsm

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