الـعيدروس

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

السلام عليكم سمي ايقونة الماكرو خالد وعين فيها هذا الكود Sub ALI() A_T = ActiveSheet.Shapes.Range(Array("Oval 1")).TextFrame2.TextRange.TrimText Cells.Find(What:=A_T, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate End Sub

السلام عليكم يوجد مدى معرف غيره إلى أي مدى تريد وغير مسمى المدى من هذا السطر Set RR = Sh.Range("My_RR") تفضل المرفق عليه تعديل لطلبك الأخير Taher_TQ_AB.rar

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

السلام عليكم ارفق ملفك الذي تريد العمل عليه وضع عليه شرح مبسط وإ ن شاء الله لن يقصر معاك الجميع

السلام عليكم ماذا تريد أن يكتب بدلاً من مرجع الخلية ؟؟ ========================= كيف يقتصر التعديل بدلا من الورقة كلها على نطاق محدد "إقتباس" ========================= جرب المرفق بخصوص مدى معين Taher_TQ_AA.rar

على هذا الرابط http://www.officena.net/ib/index.php?showtopic=41175&st=20

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

السلام عليكم بعد اذن الاستاذ الحبيب رجب جاويش بيكون هكذا للحالة الأخيرة Private Sub Worksheet_Change(ByVal T_A As Range) On Error Resume Next If Not Intersect(T_A, [C2:C100]) Is Nothing Then If T_A.Value > 1 Then _ T_A.Offset(0, -1) = 0 Else: T_A.Offset(0, -1) = Empty End Sub الحالة الأولى والثانية Private Sub Worksheet_Change(ByVal T_A As Range) On Error Resume Next ''============================================================================ 'If Not Intersect(T_A, [B2:B100]) Is Nothing Then If T_A.Value > 1 Then _ ' T_A.Offset(0, 1) = 0 Else: T_A.Offset(0, 1) = Empty ''============================================================================ If Not Intersect(T_A, [C2:C100]) Is Nothing Then If T_A.Value > 1 Then _ T_A.Offset(0, -1) = 0 Else: T_A.Offset(0, -1) = Empty ''============================================================================ End Sub

السلام عليكم جرب هكذا Private Sub CheckBox1_Change() Me.CheckBox2 = Not Me.CheckBox1 End Sub Private Sub CheckBox2_Click() Me.CheckBox1 = Not Me.CheckBox2 End Sub Private Sub UserForm_Activate() Me.CheckBox1 = False: Me.CheckBox2 = False End Sub

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

الأخ الغالي سعد عابد اشكرك على هذه الكلمات الطيبه وماندلو به في هذا المنتدى منكم وإليكم ماتعلمناه من هذا الصرح وفقك الله

الأخ الحبيب رجب جاويش أشكرك على هذا المرور العطر وفقك الله

السلام عليكم بالنسبة لحذف الملف بعد المرة الثالثه توجد عدة طريق وإما الحذف بعد وقت محدد من إقفال الملف ربما يحتاج الربط بواجهة التطبيقات وليست لدي الخبره الكافية كي البي طلبك ولاكن سوف ابحث اذا وجدت حل سوف أرفقه في هذه المشاركة إن شاء الله هذا كود حذف البرنامج بعد المحاولة الثالثة مباشرة في حدث ThisWorkBook: Public ALI_T As Byte Private Const TIMEOUT As Long = 0 Private Sub Workbook_Open() A: Dim Pass Dim AA AA = Val(TIMEOUT) Pass = InputBox("إدخل كلمة المرور", "منتدى أوفسينا") If IsNull(Pass) Or Pass = "" Then GoTo A If Pass = "123" Then MsgBox "مرحبا بك ", vbInformation, "تفضل بالدخول" Sheets(1).Activate Exit Sub End If If ALI_T = 3 Then MsgBox "المحاولة الثالثة !! الأخيرة سيتم حذف البرنامج", vbCritical, "تحذير !!!": GoTo XC ALI_T = ALI_T + 1 MsgBox "محاولة " & ALI_T & "من اصل 3 محاولات" GoTo A Exit Sub XC: MsgBox "كلمة السر خطاء للمرة الأخيرة" & Chr(13) & "سيتم حذف البرنامج ", vbOKOnly + vbMsgBoxRtlReading + vbMsgBoxRight Application.OnTime Now + TimeSerial(0, TIMEOUT, 0), Me.CodeName & ".Kill_Myself" ThisWorkbook.Close savechanges = True End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With End Sub

السلام عليكم كود إحترافي متقن بارك الله فيك استاذ عبدالله تقبل مروري

السلام عليكم الأخ الفاضل samycalls جرب المرفق تبقى إتجاه الأعمدة إن شاء الله في وقت لاحق وخصوص الذهاب إلى الإسم في الورقة إنقر على الإسم مرتين في الليست والسموحه منك على التأخير الضروف تحكم ولاكني عند وعدي تحياتي ALI_Form_Samy.rar

السلام عليكم الاخ علي بالإمكان المدى يكون ديناميك يتسع بقدر البيانات المدرجه ضمن المدى للبحث فيه واذا كان مدى البيانات ضمن الأعمدة المذكورة في الملف بيكون هكذا وبعد اذن الأستاذ رجب تعديل طفيف للكود Private Sub Worksheet_Change(ByVal Target As Range) Dim CL As Range If Not Intersect(Target, [G6]) Is Nothing Then For Each CL In Range(Cells(3, 1).Address, Cells(Rows.Count, 3).Address) If CL = [G6] Then [H6] = Cells(2, CL.Column) Exit For End If Next CL End If End Sub

السلام عليكم الأخ الفاصل هشام فكرة جميلة جدا جزاك الله كل خير وبعد إذنك الأخ الحبيب الشهابي حسب فهمي لما تريد يمكن إستبدل كود حدث UserForm_Initialize بهذا الكود Private Sub UserForm_Initialize() AL = Array("أ", "ا", "إ", "ء", "ئ", "ب", "ت", "ي", "ن", "ث", "ح", "خ", "ج", "", "", "د", "ذ", "ر", "ز", "", _ "س", "ش", "ص", "ض", "", "ط", "ظ", "ع", "غ", "", "ل", "ك", "", "", "", "ف", "ق", "", "", "", "م", "ه", "و", "ؤ", "") c9.Caption = AL(0) u9.Caption = AL(1) d9.Caption = AL(2) r9.Caption = AL(3) l9.Caption = AL(4) c8.Caption = AL(5) u8.Caption = AL(6) d8.Caption = AL(7) r8.Caption = AL(8) l8.Caption = AL(9) c7.Caption = AL(10) u7.Caption = AL(11) d7.Caption = AL(12) r7.Caption = AL(13) l7.Caption = AL(14) c6.Caption = AL(15) u6.Caption = AL(16) d6.Caption = AL(17) r6.Caption = AL(18) l6.Caption = AL(19) c5.Caption = AL(20) u5.Caption = AL(21) d5.Caption = AL(22) r5.Caption = AL(23) l5.Caption = AL(24) c4.Caption = AL(25) u4.Caption = AL(26) d4.Caption = AL(27) r4.Caption = AL(28) l4.Caption = AL(29) c3.Caption = AL(30) u3.Caption = AL(31) d3.Caption = AL(32) r3.Caption = AL(33) l3.Caption = AL(34) c2.Caption = AL(35) u2.Caption = AL(36) d2.Caption = AL(37) r2.Caption = AL(38) l2.Caption = AL(39) c1.Caption = AL(40) u1.Caption = AL(41) d1.Caption = AL(42) r1.Caption = AL(43) l1.Caption = AL(44) Hid End Sub

السلام عليكم لتعدد الحلول بطريقة الماكرو اللصق الخاص Sub Ali_TR() Application.ScreenUpdating = 0 Range(Cells(4, 3), Cells(9, 3)).Copy Sheets(2).Range("B3:B" & Sheets(2).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row).PasteSpecial Transpose:=True Application.CutCopyMode = 0 Application.ScreenUpdating = 1 End Sub

السلام عليكم عظم الله أجرك واحسن عزاك البقية في حياتك إنا لله وإنا إليه راجعون

السلام عليكم جرب هكذا Sub ALI_R() Dim TT As Range For Each TT In Range("I2:I" & Cells(Rows.Count, "I").End(xlUp).Row) If Val(TT.Value) = 0 Then TT.EntireRow.Hidden = True End If Next End Sub

السلام عليكم تفضل الملف وبه الكود مع بعض الإضافات ALI.rar

السلام عليكم الاخ الفاضل amroomo ماشاء الله تبارك الله ملف قيم مليئ بالأفكار بارك الله فيك وزادك من فضله وعلمه إلى مزيد من الإبداع تقبل مروري

احذف كود حدث اذهب الى السطر التالي في الكود If ActiveSheet.Name = "My_Con" Then Exit Sub وإستبدله بهذا If ActiveSheet.Name = "My_Con" Or ActiveSheet.Name = "Search Result" Then Exit Sub

في حدث ThisWorkbook زر طباعة يطبع نتيجة البحث التي في ListView