الـعيدروس

السلام عليكم اخي الفاضل انس دروبي ارجوا ان تكون فهمت عمل الكود الفكره بكل بساطه تفعيل واجهة الاكسل بدلا عن واجهة الفورم عند فتح الفورم كي يعمل معنا Application.onkey واضافه بسيطه تأخير ثانيه لفتح الفورم الثاني كي يعمل امر اظهار Frem2 على العموم جرب المرفق امل ان يعمل معك بكلتا الحالات تفعيل الأختصارات في أوامر الفورم222.rar

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

الاخ الحبيب ياسر خليل الكود الذي اشرت اليه كان ضمن الملف المرفق الاساسي لدى الاخ انس

السلام عليكم اخي الفاضل انس دروبي اطلع على المرفق مجرد تحايل على خاصيه Application.OnKey علها تفي بالغرض تفعيل الأختصارات في أوامر الفورم111.rar

السلام عليكم اطلع على المرفق تجربة4.rar

السلام عليكم اخي الكريم اذا اردت الاخوه يتفاعلوا مع طرحك ومشكلتك احسن طرح مشكلتك على سطر من الايضاح بهذا الشكل تريد ان نبحث عن المشكله حتى نجدها ثم نحلها كان الافضل منك ان تشرح نوع المشكله وفي اي حاله صادفتك المشكله انا تصفحت ملفك ولاارى فيه اي مشكله تظهر رسالة خطاء عند التنقل بين الواجهات المشكله انك تطلب الواجهه الاخراء قبل اخفاء التي تعمل عليها استخدمت استدعاء Form3.Show قبل امر اخفاء للحالي Me.Hide اطلع على المرفق علها تلك المشكله في ملفك تجربة3.rar

السلام عليكم تفضل جرب المرفق اظهار واحفاء الاعمدة1.rar

الاخ الفاضل مختار حسين مشكور على الملاحظه والتعديل

او هكذا هذا افضل تعديل Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range, Rng1 As Range For Each Rng In Range("TAREK").Areas If Not Application.Intersect(Target, Rng) Is Nothing Then If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then Application.EnableEvents = False Target.Offset(, -1).Select Application.EnableEvents = True MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات" Exit For Else Exit Sub End If End If Next End Sub الكود يعتمد على المدى المسمى TAREK الموجود لديك ضمن الملف

هذا حل اول استبدل الكود التالي بالذي في حدث الورقة ف الملف Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range, Rng1 As Range Dim Lis For Each Lis In ThisWorkbook.Names Set Rng = Range(Lis) If Not Application.Intersect(Target, Rng) Is Nothing Then If Cells(Rng.Cells(1, 1).Row - 1, Rng.Cells(1, 2).Column) <> CVDate(Date) Then Application.EnableEvents = False Target.Offset(, -1).Select Application.EnableEvents = True MsgBox "عفواً... ليس لديكم الصلاحية لتعديل البيانات" Exit For Else Exit Sub End If End If Next End Sub بشرط كل جدول تحط له اسم جديد جزء من الجدول كما الصوره تحط له اسم عند ادراج جدول ليوم جديد تروح تحدد كما موضح بالصورة وتحفظه بمسمى الى ان اتوصل الى حل افضل سوف ارفقه هنا

عذراً ماعملته لاينفذ ماتريد في المرفق السابق ماهو شرط الكود هل اذا تاريخ خليه C1 لايطابق الخليه الحاليه لايسمح بالتعديل ؟

السلام عليكم الاخ الفاضل زكريا اضفنا الجداول كنطاق واحد واسميته My_Nem وعند عمل جدول ليوم جديد حدث النطاق ليستوعب الجدول الجديد وهكذا اطلع على المرفق تعديل الكود1.rar

السلام عليكم اخي الكريم الكود يقوم بعمل ماذكرته اضفت لك هذي النقطه في المرفق test3.rar

السلام عليكم اطلع على المرفق وانقر على زر تنفيذ امل ان يكون به ماتريد test2.rar

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

تفضل اخي اضغط الزر الذي لديك في الورقه اضافة بيانات جديدة2.rar

السلام عليكم جرب هذا الكود ان شاء الله يفي بالغرض Sub Ali_Sort_Tble() Dim Tb As ListObject On Error Resume Next For Each Tb In ActiveSheet.ListObjects With Tb .Range.Sort key1:=.ListColumns(1), order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom End With Next On Error GoTo 0 End Sub

تفضل اضافة بيانات جديدة1.rar

جرب هذا الكود وشغله من ورقة التخصص اتمني يكون مطلبك Sub Rtrn_S() Dim Ac, Rw, LR, r Dim Sh As Worksheet Application.ScreenUpdating = False Set Sh = ورقة1: Ac = "B1" For r = 2 To Sh.Cells(Rows.Count, 7).End(xlUp).Row LR = Cells(Rows.Count, 1).End(xlUp).Row + 1 With My_Rn If Sh.Cells(r, 15) = Range(Ac) Then Rw = r Sh.Range(Sh.Cells(Rw, 1), Sh.Cells(Rw, 49)).SpecialCells(xlCellTypeVisible).Copy Cells(LR, 1).PasteSpecial xlPasteValues End If End With Next

السلام عليكم او بهذي الطريقه نسجل باسورد محرر الاكواد ضمن الكود Private Sub باسوورد() ' الكود في وضع الخاص (مخفي) وحفظ اسم الكود بمسمى معين ' بإستخدام كلمة Private ' Private Sub باسوورد Call Un_VBPro("123") ' مثلا اذا الباسورد حق محرر الاكواد 123 End Sub Private Sub Un_VBPro(ByVal Pwd As String) Dim vbProj As Object Set vbProj = ThisWorkbook.VBProject If vbProj.Protection <> 1 Then Exit Sub ' Set Application.VBE.ActiveVBProject = vbProj SendKeys Pwd & "~~" Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute Application.VBE.MainWindow.Visible = True DoEvents With Application .Goto "باسوورد" End With End Sub

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

السلام عليكم اخي bebo2all اضف الامر التالي لتجاوز الخطاء في اول الكود ان شاء الله يمشي الحال معك on error resume next

السلام عليكم اضف PtrSafe الى السطر المشار في حدث ThisWorkbook ليصبح كالتالي : Declare PtrSafe Function GetSystemTime Lib "mzml32" (lpSystemTime As SYSTEMTIME)

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

الف الف مبروك على الترقيه اخي ياسر خليل وتستاهل اكثر نتمنى لك مزيد من التقدم والرقي تقبل مروري