عبدالله باقشير

اخي الفاضل محمد الريفى

اخي الحبيب محمود عبد السميع

السلام عليكم ورحمة الله وبركاته جزاكم الله خيرا والف ميروك على الترقية تقبلوا تحياتي وشكري

السلام عليكم جزاكم الله خيرا وكل عام وانتم بخير

عيد مبارك وكل عام وانتم بخير جميعا تقبل الله من ومنكم صالح الاعمال

السلام عليكم جرب هذا Sub Macro1() Dim cel As Range, ArRng As Range Dim i As Long On Error GoTo 1 With Range(Range("A1"), Range("A1").End(xlDown)) For Each cel In .Cells i = i + 1 cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2) If WorksheetFunction.CountIf(.Cells.Resize(i, 1), cel.Value) >= 2 Then If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel) End If Next If Not ArRng Is Nothing Then ArRng.Delete .Sort .Columns(1), xlAscending End With 1: Set ArRng = Nothing End Sub تحياتي

جزاكم الله خيرا هذا مع حذف المكرر Sub Macro1() Dim cel As Range, ArRng As Range Dim i As Long On Error GoTo 1 With Range(Range("A1"), Range("A1").End(xlDown)) For Each cel In .Cells i = i + 1 cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2) If WorksheetFunction.CountIf(.Cells.Resize(i, 1), cel.Value) = 2 Then If ArRng Is Nothing Then Set ArRng = cel Else Set ArRng = Union(ArRng, cel) End If Next If Not ArRng Is Nothing Then ArRng.Delete .Sort .Columns(1), xlAscending End With 1: Set ArRng = Nothing End Sub تحياتي

السلام عليكم جرب هذا على السريع بدون حذف المكرر Sub Macro1() Dim cel As Range On Error GoTo 1 With Range(Range("A1"), Range("A1").End(xlDown)) For Each cel In .Cells cel.Value = Split(CStr(cel), ".")(1) & "/" & Split(CStr(cel), ".")(0) & "/" & Split(CStr(cel), ".")(2) Next .Sort .Columns(1), xlAscending End With 1: End Sub تحياتي

السلام عليكم المرفق 2010 transfir.rar

السلام عليكم Private Sub Worksheet_SelectionChange(ByVal Target As Range) Range("yyy").Interior.Color = [B2].Interior.Color ورقة2.Range("RRR").Interior.Color = [B2].Interior.Color End Sub تحياتي

السلام عليكم شاهد المرفق 2010 transfir.rar

السلام عليكم الشكر واصل لاخي الجبيب جمال ولكني اظن ان هذا المطلوب وهو ازاحة الى اليمين Sub DelEmpty() Cells.Worksheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete (xlToLeft) End Sub تحياتي

السلام عليكم تم اضافة افورم المرن الاصدار الثالث مع امكانية الطباعة http://www.officena.net/ib/index.php?showtopic=52300 المرفق 2010 hhh.rar

السلام عليكم جرب التعديل التالي : Private Sub Worksheet_Change(ByVal Target As Range) Const pwd As String = "123" Static N As Boolean If N Then Exit Sub If Not Application.Intersect(Target, Range("A:A")) Is Nothing Then If Application.InputBox("برجاء إدخال كلمة المرور لدخول لتعديل البيانات", "تصريح دخول الورقة", "ابراهيم محمد 01067016251") <> pwd Then Application.EnableEvents = False Application.Undo Application.EnableEvents = True MsgBox "عفوا ليس لديكم الصلاحية لاتمام هذا الاجراء" Else MsgBox "تم التعديل بنجاح" N = True End If End If End Sub تحياتي

وعليكم السلام تفضل المرفق 2010 ts2.rar

السلام عليكم جرب هذا بعد وضعه في موديل الورقة ts2 Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo 1 If Target.Address = [M5].Address Then Range("A11:A67").EntireRow.Hidden = False M = Application.Match([M5], Range("A11:A67"), 0) + 11 If M <= 67 Then Range("A" & M & ":A67").EntireRow.Hidden = True End If 1 End Sub تحياتي

الملف يعمل ....هل اشتغلت من قبل بملفات فيها اكواد اذا كانت الاجابة لا ...فعل الماكرو في ملفك او ابحث عن مواضيع تفعيل الماكرو في المنتدى

السلام عليكم جرب الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim s As Integer, t1 As Integer Dim t2 On Error GoTo 1 If Target.Address = [c3].Address Then t1 = Split(CStr(Target), "-")(0) t2 = Split(CStr(Target), "-")(1) For s = 1 To Sheets.Count Sheets(s).Name = t1 & "-" & t2 t1 = t1 + 1 Next End If 1 End Sub المرفق 2003 تسمية الشيتات.rar

السلام عليكم جرب الكود التالي Sub Macro1() Dim LR As Long With Range("A4:C" & Cells(Rows.Count, "A").End(xlUp).Row) If .Row = 4 Then LR = Cells(Rows.Count, "G").End(xlUp).Row + 1 Cells(LR, "G").Resize(.Rows.Count, 1).Value = Date Cells(LR, "H").Resize(.Rows.Count, 3).Value = .Value End If End With End Sub تحياتي

السلام عليكم شاهد الفيديو XXX.rar

السلام عليكم اولا العنوان مخالف وسيتم تعديله فارجوا الانتباه لهذه النقطة مستقبلا استخدم معادلة الصفيف التالية: =MIN(IF((H3:DR3)>0;H3:DR3;"")) اضغط F2 لتحرير الصيغة ثم اضغط (كترل + شيفت + انتر) المرفق 2003 Bonbmnhok1.rar

هذا نفس المعلومات على الاكسل SystemInfo.rar

نم تحويل الكود على فورم الاكسل المرفق 2003 SystemInfo.rar

السلام عليكم =VLOOKUP(C1;$A$1:$B$7;2;0) تحياتي

السلام عليكم شاهد المرفق 2010 مخطط الإجازات الإحترافي.rar