الـعيدروس

السلام عليكم جرب هذا الكود في حدث ThisworkbooK Private Sub Workbook_Open() Sheets(1).Select Dim A As String AA = Format(Now(), "[$-1170000]ddd;@") If Not AA = "الجمعة" Then Else For C = 1 To 32 A = Cells(2, C).Text If A = AA Then Range(Cells(1, C), Cells(30, C)).Interior.Color = RGB(166, 166, 166) End If Next End If End Sub

السلام عليكم الاخ الفاضل skyblue ماهو إصدار الأوفيس الذي تستخدمه ؟؟

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

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

السلام عليكم اعمل تحديد ناحية الطباعه للمدى المراد وإستخدم هذا الكود Sub A() On Error Resume Next Dim ZO As Range Set ZO = Range(ActiveSheet.PageSetup.PrintArea) ZO.CopyPicture xlScreen, xlBitmap ActiveSheet.Paste Destination:=ZO ActiveWindow.SelectedSheets.PrintPreview ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete End Sub

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

السلام عليكم إختصار للكود Private Sub CommandButton1_Click() Dim T As Worksheet For Each T In Application.Worksheets If Not T.Name = Me.TextBox1 And Not Me.TextBox1 = Empty Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = Me.TextBox1: Exit Sub Else: MsgBox "مسمى مكرر": Exit Sub End If Next T End Sub

السلام عليكم جرب هكذا Private Sub CommandButton1_Click() Dim SH As Worksheet Dim T As Worksheet A = Me.TextBox1 For Each T In Application.Worksheets If Not T.Name = A Then GoTo 0 Else M = M & "إسم الورقة موجود مسبقاً" GoTo 1 End If Next T Exit Sub 0: Set SH = Worksheets.Add SH.Name = A SH.Move After:=Sheets(Sheets.Count) ActiveSheet.DisplayRightToLeft = False Exit Sub 1: MsgBox M End Sub

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

السلام عليكم حط هذا الكود في حدث الفورم Private Sub CommandButton1_Click() Dim SH As Worksheet A = Me.TextBox1 Set SH = Worksheets.Add SH.Name = A SH.Move After:=Sheets(Sheets.Count) ActiveSheet.DisplayRightToLeft = False End Sub

السلام عليكم الاستاذ الكبير عبدالله باقشير ( خبور خير ) حفظك الله ورعاك جزاك الله خير على هذا العمل الجميل المتقن زادك الله علما ورفعه تقبل مروري

السلام عليكم جزاك الله خير استاذ رجب جاويش تقبل مروري

السلام عليكم الاخ ايسم جرب هذا الكود Sub AA() [A1] = WorksheetFunction.Sum(Range(Cells(2, "A").Address, Cells(Rows.Count, "A").Address)) End Sub

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

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

السلام عليكم جرب هذا الكود ربما اكون اصبت به لان الاعمدة تختلف عن الصفوف بقياس السنتيمتر والبكسل Sub AA() On Error Resume Next Dim XX As Integer ' ************************************* ' حدد بالماوس الخلايا المراد تحويلها ثم فعل الكود ' XX = Application.InputBox("عرض الصفوف", "officena") If XX Then Selection.RowHeight = Application.CentimetersToPoints(XX) End If XX = Application.InputBox("عرض الأعمدة", "officena") If XX Then Selection.ColumnWidth = XX * 4.663 End If End Sub

السلام عليكم اخي سعيد جرب هذه الأداة CentimetersToPoints ربما تجد ضالتك بها جرب هذا الكود ( في مودويل ) Sub A() Columns(1).ColumnWidth = Application.CentimetersToPoints(1) Rows(1).RowHeight = Application.CentimetersToPoints(1) End Sub

السلام عليكم الأخ الحبيب سعد عابد جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل محمد مصطفى ( أبو حمزة ) جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل فضل 1 جزاك الله خير على التهنئة ومرورك العطر الأخ الأستاذ الحبيب احمد فضيله مرورك شرف كبير تعلمنا منك الكثير استاذ احمد جزاك الله الف خير الأخ الفاضل عباس السماوي جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل mahmoud zaid جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل MAHMOUDFOXMAM جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل سعيد بيرم جزاك الله خير على التهنئة ومرورك العطر الأستاذ القدير دغيدي جزاك الله الف خير استاذنا الحبيب ومرورك والتهنئة شرف كبير ونعتز به الأخ الفاضل tahar1983 جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل aghanem جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل أبو ردينة جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل jarwan جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل jazea جزاك الله خير على التهنئة ومرورك العطر الأخ الفاضل الشهابي جزاك الله خير على التهنئة ومرورك العطر الأستاذ القدير احمدزمان جزاك الله الف خير على التهنئة استاذ احمد يعقوب مرورك والتهنئة شرف كبير ووسام نحطه على الصدر ونعتز به الأستاذ القدير هشام شلبى جزاك الله خير استاذ هشام وشكر على المرور العطر والتهنئة الطيبه انت احد نجوم هذا الصرح الذي تعلمنا منهم الكثير الأستاذ القدير محمد يحياوي جزاك الله خير استاذ محمد وشكرا لك على التهنئة ومرورك الكريم الأخ الفاضل Eid Mostafa جزاك الله خير على التهنئة ومرورك العطر ============================ إن شاء الله نكون عند حسن الضن والسلام عليكم

السلام عليكم إستبدل كود حدث الورقة TextBox بهذا > نفس الكود لاكن عليه اضافة طفيفة Private Sub TextBox1_Change() Application.ScreenUpdating = False Application.EnableEvents = False Dim lastrow As Long lastrow = Range("b65535").End(xlUp).Row If TextBox1.Text <> "" Then ActiveSheet.Range("$A$7:$k$" & lastrow).AutoFilter Field:=2, Criteria1:= _ "=" & "*" & TextBox1.Text & "*", Operator:=xlOr Else ActiveSheet.Range("$A$7:$k$" & lastrow).AutoFilter Field:=2, Criteria1:= _ "=" & "*" & TextBox1.Text & "*", Operator:=xlOr End If Application.ScreenUpdating = True Application.EnableEvents = True End Sub

السلام عليكم جرب هذا الكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim SH As Worksheet Dim M As Range, RR As Range '**************** ' الورقة النشطه غيرها إلى أي ورقة تريد Set SH = ActiveSheet '**************** ' المدى المراد البحث فيه Set RR = SH.[A2:A100] '**************** If Target.Count > 1 And IsEmpty(Target.Value) = False Then Exit Sub If Not Intersect(Target, [H2]) Is Nothing Then For Each M In RR If Target.Value = M.Value Then M.Resize(1, 6).Copy Cells(Cells(Rows.Count, "J").End(xlUp).Offset(1, 0).Row, "J").PasteSpecial xlPasteValues Exit For End If Next Application.CutCopyMode = False Target.Select End If End Sub

السلام عليكم الاخ الفاضل عيد إذا تقصد خلية جمع المدخلات فيها فرضا أن الخلية المعنيه A2 جرب هكذا كود في حدث الورقة Private Sub Worksheet_Change(ByVal ALI As Excel.Range) Static ALI_S As Double With ALI If .Address(0, 0) = "A2" Then If Not IsEmpty(.Value) And IsNumeric(.Value) Then ALI_S = ALI_S + .Value Else ALI_S = 0 End If Application.EnableEvents = False .Value = ALI_S Application.EnableEvents = True End If End With End Sub وعندما يتم إقفال المصنف يتم تصفير القيمة في المتغير

السلام عليكم بالنسبة للإختصار التابع للأوفيس لأعلم ولكن بالإمكان عمل إختصار حط هذا الكود في حدث Thisworkbook عمل الكود لفتح القائمة بزر F3 Private Sub Workbook_Open() Application.OnKey "{F3}", "FF" End Sub وهذا الكود في مودويل Sub FF() '******************* ' غير المدى إلى أي مدى تريد Set My_R = ActiveSheet.Range("A1:M1") ' '******************* If Not Intersect(ActiveCell, My_R) Is Nothing Then With Application .Goto ActiveCell .SendKeys ("%{DOWN}") End With End If End Sub Ali_By.rar

السلام عليكم الاخ الفاضل em_acc يمكنك من البرنامج التابع للويندوز المسمى جدولة المهام اتبع الشرح في المرفقات تصفح البرنامج مزبوط بالإمكان توقيت ملف اكسل او غيره تضيف اكثر من مهمه تحذف مهمه وأشياء أكتشفها بنفسك A.rar

السلام عليكم لتعدد الحلول جرب المرفق UserForm1_ALI.rar

السلام عليكم الاستاذ القدير عبدالله المجرب حفظك الله ورعاك اشكرك على هذا التشجيع ولاطالما عهدناه منك واشكر الإدارة على منح هذه الثقة وإن شاء الله نكون عند حسن الضن وشكراً للأخوة الأعضاء على الردود والمرور الكريم نسئل الله التوفيق والسداد للجميع