أبو حنــــين

جرب المثال التالي نموذج.rar

بعد اذن اخي محمود جرب المرفق بيانات.rar

جرب هذا المثال مثال.rar

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

قبل كتابة الكود يجب عمل الآتي : ـ 1 ) تحديد كل خلايا الورقة الاولى ـ 2 ) الضغط بيمين الفأرة للوصول الى : تنسيق ـ 3 ) ثم الذهاب الى حماية ـ 4 ) ثم التأشير على كلمة : مخفية و بعد ذلك تعيد نفس العمل مع باقي الاوراق ثم تقوم بتشغل الكود

كل عام و انت بخير أخي عمرو رحيل أعاده الله علينا و عليكم و على الأمة الاسلامية بالخير و اليمن و البركات

البقاء لله انا لله وانا اليه راجعون أخي العزيز سعيد : عظم الله أجركم و ألهمكم الصبر و أسكن الفقيدة فسيح الجنان

للحماية استعمل هذا الكود : Private Sub CommandButton1_Click() On Error Resume Next For Each Sh In ThisWorkbook.Sheets Sh.Protect Password:="123" Next End Sub و لفك الحماية استعمل هذا الكود : Private Sub CommandButton2_Click() On Error Resume Next For Each Sh In ThisWorkbook.Sheets Sh.Unprotect Password:="123" Next End Sub حيث الاعداد 123 هي كلمة السر و يمكنك تغييرها

مبروك لأخي الحبيب عبد الله على المولودة الجديدة التي ولدت في الشهر الكريم ندعو الله ان تتربى في عزه و ندعو الله لها الصلاح في الدنيا و الفوز بالآخرة

سؤال .. هل يمكن تحديد خلية بعد آخر خلية موجود فيها البيانات ؟؟ =HYPERLINK(CONCATENATE(NAMEFIL;"A";ROWEND+1);"END") وهذا الكود لأخونا الكريم عبد الله جزاه الله خيرا

بعد إذن اخي حاجي بن عليه يمكن استعمال الكود التالي Private Sub Worksheet_Selectionchange(ByVal Target As Range) Selection.NumberFormat = "[$-2000000]_-* # ##0_-;_-* # ##0-;_-* ""-""??_-;_-@_-" End Sub

بعد اذن اخي رجب يمكن استعمال الكود الذي أدلى به أخي الحبيب رجب بالطريقة التالية Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Cancel = True If Target.Column = 1 Then Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1).Select End If End Sub حيث تضغط مرتين على الخلية A1 لتنتقل الى آخر خلية تحتوي على معلومات

العفو أخي أكرم جلال

جرب المرفق فورم معلومات.rar

السلام عليكم فورم معلومات.rar

السلام عليكم اضغط مرتين على زر البحث الموجود في الفورم ستجد كود قم بحذفه و استبدله بالكود التالي : Private Sub ButtonFind_Click() Dim MyValue Dim MyAr() As String Dim ib As Boolean Dim R As Integer, i As Integer, ii As Integer Dim MyColmnFind As Integer, LastRow As Integer Dim dt1 As Date, dt2 As Date MyColmnFind = Me.ComboFind.ListIndex + 1 If MyColmnFind = 0 Then Exit Sub If MyColmnFind = 3 Then Me.TextFind = "" Me.ListFind.Clear With sRng.Worksheet LastRow = .Range("A65536").End(xlUp).Row If IsDate(Me.TextDate1) Then dt1 = DateValue(Me.TextDate1) Else dt1 = WorksheetFunction.Min(.Range("C2").Resize(LastRow)): Me.TextDate1 = Format(dt1, DateFormt) If IsDate(Me.TextDate2) Then dt2 = DateValue(Me.TextDate2) Else dt2 = WorksheetFunction.Max(.Range("C2").Resize(LastRow)): Me.TextDate2 = Format(dt2, DateFormt) End With sColmn = "" With sRng For R = 2 To LastRow Select Case .Cells(R, 3).Value2: Case dt1 To dt2 ib = InStr(1, .Cells(R, MyColmnFind), Me.TextFind, vbTextCompare) = 1 If ib Then sColmn = sColmn & R & " " ii = ii + 1 ReDim Preserve MyAr(1 To ContColmn, 1 To ii) For i = 1 To ContColmn If IsDate(.Cells(R, i)) Then MyValue = Format(.Cells(R, i).Value2, DateFormt) _ Else: MyValue = .Cells(R, i).Value2 MyAr(i, ii) = MyValue Next End If End Select Next End With If ii Then Me.ListFind.Column = MyAr: Me.ListFind.ListIndex = 0 For s = 0 To ListFind.ListCount ListFind.ListIndex = s - 1 If s Then ListFind.Column(3) = Format(ListFind.Column(3), "hh:mm AM/PM") End If Next End Sub

أنظر الرابط http://www.officena.net/ib/index.php?showtopic=41782&hl=

او استعمل هذا الكود للخروج النهائي Application.Quit

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

فرز الأسماء كشف تنسيق.rar

مرحبا يمكنك كتابة التالي في الخلية الصفراء =VLOOKUP(G4;A3:B14;2;0)

غير الكود السابق بهذا الكود فانه ينقص الاهتزاز نوعا ما Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Range("D9:D108").Sort Key1:=Range("D9"), Order1:=xlAscending Range("I9:I108").Sort Key1:=Range("I9"), Order1:=xlAscending Range("O9:O108").Sort Key1:=Range("O9"), Order1:=xlAscending Range("U9:U108").Sort Key1:=Range("U9"), Order1:=xlAscending Range("AA9:AA108").Sort Key1:=Range("AA9"), Order1:=xlAscending Range("AG9:AG108").Sort Key1:=Range("AG9"), Order1:=xlAscending Range("AM9:AM108").Sort Key1:=Range("AM9"), Order1:=xlAscending Range("AS9:AS108").Sort Key1:=Range("AS9"), Order1:=xlAscending Range("AY9:AY108").Sort Key1:=Range("AY9"), Order1:=xlAscending Range("BE9:BE108").Sort Key1:=Range("BE9"), Order1:=xlAscending Range("BK9:BK108").Sort Key1:=Range("BK9"), Order1:=xlAscending Range("BQ9:BQ108").Sort Key1:=Range("BQ9"), Order1:=xlAscending Application.ScreenUpdating = True End Sub

العفو أخي الكريم محمود ، و رمضان مبارك ان شاء الله

هل تقصد هكذا ؟ تعديل كود.rar

جرب المرفق الجهة.rar