الـعيدروس

السلام عليكم جرب الكود التالي لاتنسى تغير مسمى الشيك الاول من كامله الى كامل Public Sub Ali_Shp() Dim A$, B$, C$, D$, V$ With ورقة1 Dim S As Shape, S1 As Shape, S2 As Shape, S3 As Shape Set S = .Shapes("خانة اختيار 1"): Set S1 = .Shapes("خانة اختيار 2") Set S2 = .Shapes("خانة اختيار 3"): Set S3 = .Shapes("خانة اختيار 4") S.Select: Selection.LinkedCell = [x1].Address S1.Select: Selection.LinkedCell = [x2].Address S2.Select: Selection.LinkedCell = [x3].Address S3.Select: Selection.LinkedCell = [x4].Address A = IIf([x1].Value, S.AlternativeText, "") B = IIf([x2].Value, S1.AlternativeText, "") C = IIf([x3].Value, S2.AlternativeText, "") D = IIf([x4].Value, S3.AlternativeText, "") .ListObjects("الجدول1").Range.AutoFilter Field:=4, Criteria1:=Array(A, B, C, D), Operator:=xlFilterValues [A1].Select End With End Sub تحياتي تصفيه بالكود_A.rar

السلام عليكم تفضل Dim x As Variant Dim Sh As Worksheet Sub pro_unpro() On Error Resume Next Dim XX As Shape Set XX = ActiveSheet.Shapes("Button 18") With XX.TextFrame.Characters If .Text = "حماية" Then .Text = "فك الحماية" protectAll Else unprotectAll .Text = "حماية" End If End With On Error GoTo 0 End Sub Sub protectAll() x = Application.Dialogs(28).Show If x = True Then For Each Sh In ThisWorkbook.Worksheets Sh.Protect Password:=x Next End If End Sub Sub unprotectAll() x = Application.Dialogs(28).Show If x = True Then For Each Sh In ThisWorkbook.Worksheets Sh.Unprotect Password:=x Next End If End Sub

بعد اذن استاذي طارق محمود بيكون التعديل على الكود كالتالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$H$2" Then Exit Sub If Target = "" Then Cells.AutoFilter: Exit Sub LR = Cells.SpecialCells(xlCellTypeLastCell).Row - 1 Range("A2:E" & LR).Select Selection.AutoFilter Selection.AutoFilter Field:=2, Criteria1:=[H2] Selection.AutoFilter Field:=1, Criteria1:="=" End Sub

طيب جرب هذا الكود من أعمال احد اساتذة المنتدى التكست الذي تريده بالعربي تحط في حدث التكست ChaingeLanguage "Arabic" والانجليزي تحط ChaingeLanguage "English" Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long Sub ChaingeLanguage(KBLang As String) Dim pwszKLID As String Select Case KBLang Case "Arabic" pwszKLID = "00000401" Case "English" pwszKLID = "00000409" End Select LoadKeyboardLayout pwszKLID, 1 End Sub Private Sub TextBox1_Enter() ChaingeLanguage "Arabic" Exit Sub End Sub Private Sub TextBox2_Enter() ChaingeLanguage "English" Exit Sub End Sub

جربت الكود يعمل بكفائة أين المشكلة ؟؟؟

السلام عليكم ربما هذا يفيد الصق الاكواد في حدث الفورم Private Sub TextBox1_Enter() Application.SendKeys ("%+") End Sub Private Sub TextBox2_Enter() Application.SendKeys ("%+") End Sub

السلام عليكم بخصوص الطلب الأول أعتقد أنه فعال في المرفق السابق الطلب الأخر جرب المرفق فورم مخصص_A2.rar

ادخلت رقم سري خاطئ تأكد من حالة الأحرف إن كان به حروف رغم إن التعديل يعمل ماطلبت يحمي جميع الاوراق ويغلي الحماية إن كنت تريد صندوق إدخال للرقم السري بدل من الولوج الى محرر الاكواد Public ws As Worksheet Sub ProtectAllSheets() Dim Pas As Integer Pas = InputBox("ادخل الرقم السري", "رمز الحماية") If Pas = False Or Pas = Cancel Then Exit Sub For Each ws In Worksheets ws.Protect Password:=Pas Next ws End Sub Sub UnProtectAllSheets() Dim Pas As Integer Pas = InputBox("ادخل الرقم السري", "إلغاء الحماية") If Pas = False Or Pas = Cancel Then Exit Sub For Each ws In Worksheets On Error GoTo 0: ws.Unprotect Password:=Pas Next ws Exit Sub 0: MsgBox "كلمة المرور خطاء تأكد من حالة الأحرف", vbExclamation, "تنبية !!!" End Sub

السلام عليكم Public ws As Worksheet Private Const Pas As String = "123" ' الباسورد للحماية Sub ProtectAllSheets() For Each ws In Worksheets ws.Protect Password:=Pas Next ws End Sub Sub UnProtectAllSheets() For Each ws In Worksheets ws.Unprotect Password:=Pas Next ws End Sub

ما المطلوب من الكود أن يفعل ؟

السلام عليكم فرضا عمود شرط اللون وشرط رقم 1 هو الـ C شرط اللون الاصفر جرب الكود التالي Public Sub Hid_Ali() Dim i% For i = 1000 To 2 Step -1 With Cells(i, 3) If Not IsEmpty(.Value) And .Value = 1 Or .Interior.Color = RGB(255, 255, 0) Then .EntireRow.Hidden = True End If End With Next End Sub

السلام عليكم بعد اذن اخي الحسامي اعتقد انه هو البرنامج الذي كان في هذه المشاركه تفضل المرفق 2003 و 2007 شجرة الحسابات-عماد الحسامي_2003.rar شجرة الحسابات-عماد الحسامي_2007.rar

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

هذا الكود الصقه في حدث Userform Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) With ThisWorkbook Application.DisplayAlerts = False .Save .Close Application.DisplayAlerts = True End With End Sub وكود حدث Thisworkbook إستبدله بالتالي Private Sub WorkBook_Open() Dim i As Integer Dim x As Worksheet i = 2 For Each x In ThisWorkbook.Worksheets If x.Visible = xlSheetHidden Or x.Visible = lSheetVeryHidden Then Else ورقة1.Cells(i, 13).Value = x.Name i = i + 1 End If Next x End Sub

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

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

السلام عليكم اخي jo11 بعد تجربة الكود السابق على العامود A لاحظت وجود خطاء في نتائج بعض الخلايا إستخدم الكود التالي بعد التعديل Public Function Rd_Ali(ByVal R As String) As Currency Application.Volatile x = CCur(R) Rd_Ali = Int(x) + Int(20 * (x - Int(x))) / 20 End Function

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

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

السلام عليكم الغي RowSource من خصائص الـ ComboBox1 ثم انسخ الكود التالي في حدث UserForm_Activate With Me.ComboBox1 For i = 4 To 100 If IsNumeric(Cells(i, 1)) Then .AddItem Cells(i, 1).Value End If Next End With

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

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

السلام عليكم استبدل كود حدث ورقة الطباعه بالتالي بعد التعديل Private Sub Worksheet_Change(ByVal Target As Range) 'بواسطة ابو نصار أ. عبــاد On Error Resume Next Set MYRNG = Sheets("البيانات").[A1:AG1000] If Not Intersect(Target, [B8]) Is Nothing Then With Application For I = 1 To 35 c = Choose(I, 3, 4, 5, 6, 7, 8, 9, 11, 12, 13, 14, 16, 17, 18, 19) Cr = Choose(I, 2, 20, 27, 6, 4, 12, 7, 23, 24, 25, 26, 18, 33, 19, 22) If c = Null Or Cr = Null Then GoTo 0 Cells(Target.Row + c, 2) = IIf(IsError(.VLookup(Target, MYRNG, Cr, 0)), "", .VLookup(Target, MYRNG, Cr, 0)) 0 Next .EnableEvents = False '************* Ali_Ddif [B25], [B28] '************* .EnableEvents = True End With Set MYRNG = Nothing End If End Sub Private Sub Ali_Ddif(ByVal Target As Range, R As Range) Dim Dif_A%, I_a%, m_a%, N_a%, I% '******************************************************* On Error Resume Next If IsDate(Target.Value) Then Dif_A = Target - Date If Dif_A < 0 Then '******************************************************* I_a = Dif_Ali(Format(Target, "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "md") m_a = Dif_Ali(Format(Target, "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "ym") N_a = Dif_Ali(Format(Target, "mm/dd/yyyy"), Format(Date, "mm/dd/yyyy"), "y") '******************************************************* With R .Font.Color = IIf(N_a >= 0 And m_a >= 0 And I_a >= 0, RGB(255, 0, 0), RGB(0, 176, 80)) .Value = " الإقامة أنتهــت منـذ " & N_a & " سنة , " & m_a & " شهور و " & I_a & " يوم ." End With Else '******************************************************* I_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(Target, "mm/dd/yyyy"), "md") m_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(Target, "mm/dd/yyyy"), "ym") N_a = Dif_Ali(Format(Date, "mm/dd/yyyy"), Format(Target, "mm/dd/yyyy"), "y") '******************************************************* With R .Font.Color = IIf(N_a = 0 And m_a = 0 And I_a <= 0, RGB(255, 0, 0), RGB(0, 176, 80)) .Value = " الأقامة تنتهي بعد " & N_a & " سنة , " & m_a & " شهور و , " & I_a & " يوم . " End With End If End If End Sub Private Function Dif_Ali(ByVal Fr_D As String, ByVal Sc_D As String, ByVal St_D As String) As Long Dif_Ali = Evaluate("DATEDIF(DATEVALUE(""" & Fr_D & """),DATEVALUE(""" & Sc_D & """),""" & St_D & """)") End Function أرجو التجربه

الأخ أبو تميم تعلم أن التعديل يأخذ وقت وتركيز وجهد مضاعف من أن أعمل برنامج جديد فأرجو إمهالي بعض الوقت

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