الـعيدروس

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

السلام عليكم الاساتذه الافاضل توصلت الى حل رغم كبر الكود ولاكن ادا مااريده الاضافه هيا عند جلب تصنيف بعد اخر صف يعمل جمع لاعمده محدده ويقوم بعمل تنسيق خطين فوق بعض مع خط معين وتوسيط ولون ================================ مااريده هو عند جلب تصنيف يقوم بالغاء التنسيق الاول الذي تم عمله من الاجلب الاخير وبعد الجلب يقوم بعمل التنسيقات مره اخر وهكذا ================================= هذا الكود Private Sub ComboBox2_Change() Range("a3:az" & Rows.Count).ClearContents 'ClearContents Application.ScreenUpdating = False [a3: ax2000].ClearContents shtMain.[a3:az3].AutoFilter shtMain.[a3:az3].AutoFilter Field:=6, Criteria1:=ComboBox2 shtMain.Range("A4:Az2000").SpecialCells(xlCellTypeVisible).Copy Range("a3").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False shtMain.[a3:az3].AutoFilter X = Range("b15000").End(xlUp).Row + 1 Cells(X, "b") = "المجمـــــوع" Cells(X, "c") = Application.WorksheetFunction.SUM(Range([c3], Cells(X, "c"))) Cells(X, "an") = Application.WorksheetFunction.SUM(Range([an3], Cells(X, "an"))) Cells(X, "ao") = Application.WorksheetFunction.SUM(Range([ao3], Cells(X, "ao"))) Cells(X, "aq") = Application.WorksheetFunction.SUM(Range([aq3], Cells(X, "aq"))) Cells(X, "aw") = Application.WorksheetFunction.SUM(Range([aw3], Cells(X, "aw"))) [ba1].Select '================================================= Range("b1000").End(xlUp).Select ' تنسيق اخر صف فيه بيانات '================================================= '================================تحديد لون التعبئه With Selection.EntireRow.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With '================================ Selection.EntireRow.Font.Bold = True Selection.Font.Underline = xlUnderlineStyleSingle With Selection.EntireRow.Font .Name = "Traditional Arabic" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleSingle .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With Selection.Font.Size = 12 Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.EntireRow.Borders(xlEdgeLeft) .LineStyle = xlDouble .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThick End With With Selection.EntireRow.Borders(xlEdgeTop) .LineStyle = xlDouble .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThick End With With Selection.EntireRow.Borders(xlEdgeBottom) .LineStyle = xlDouble .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThick End With With Selection.EntireRow.Borders(xlEdgeRight) .LineStyle = xlDouble .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThick End With With Selection.EntireRow.Borders(xlInsideVertical) .LineStyle = xlDouble .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlThick End With Selection.Borders(xlInsideHorizontal).LineStyle = xlNone '===========================================توسيط الخط في الصف With Selection.EntireRow .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection.EntireRow .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With End Sub ارجو التكرم من احد الاساتذه بعمل الاضافه

اخي الفاضل ارفق مثال

فعلا قائمة الاكواد مغلقة برقم سري

العذر منك والسموحه استاذ كيماس لم ارى ردك الا بعد المشاركه

السلام عليكم اتفضل ملف به الشرح في المرفقات

هلابيك اخ سعد نورت الموضوع وشكرا جدا على مرورك العطر

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

السلام عليكم الاخوة الافاضل يحياوي وياسر مشكورين جدا على الكلمات الجميله وهذا كود لعمل اوراق جديد بحسب ماتكتبه في العمود A من السطر الثاني كم تشاء من الاوراق وعمل ارتباط تشعبي في كل ورقة جديدة العودة الى الورقه الرئيسية ارجو ان تستفيدو منه Option Explicit Sub CreateSheets() Dim RNG As Range Dim c As Range Application.ScreenUpdating = False Set RNG = ActiveSheet.Range("A2:A" & Rows.Count).SpecialCells(xlConstants) For Each c In RNG If Not Evaluate("ISREF('" & c.Text & "'!A1)") Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Text Else Sheets(c.Text).Move After:=Sheets(Sheets.Count) End If Sheets(c.Text).Range("A1").Formula = "=HYPERLINK(""#ورقة1!A1"",""الرئيسية"")" c.Offset(, 1).FormulaR1C1 = "=HYPERLINK(""#'"" & RC[-1] & ""'!A1"", ""Link"")" Next c RNG.Parent.Activate Application.ScreenUpdating = True End Sub والمرفق ملف تجربه تحياتي والسلام عليكم كود عمل اوراق.rar

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

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

الاخ محمد مشكور على المرور وفقك الله

للرفع يااساتذه الأكواد الله يرفع قدركم

السلام عليكم الاخوة الافاضل هذا كود لعمل باسورد حماية لكافة اوراق الملف انشاء الله يفيدكم Option Explicit Sub ProtectAllSheets() Dim pwd As String, pwd2 As String Dim ws As Worksheet Do pwd = Application.InputBox("ادخل الباسورد?", "عمل باسورد للصفحات", Type:=2) If pwd = "False" Then Exit Sub pwd2 = Application.InputBox("اعد ادخال الباسورد للتأكيد ?", "التأكد من الباسورد", Type:=2) If pwd2 = "False" Then Exit Sub If pwd = pwd2 Then Exit Do Else MsgBox "عفـواً الباسور غير مطابق" Loop For Each ws In Worksheets ws.Protect Password:=pwd Next ws End Sub وهذا الغاء باسورد الحمايه Option Explicit Sub UnProtectAllSheets() Dim pwd As String, ws As Worksheet On Error Resume Next pwd = Application.InputBox("الرجاء ادخال الباسورد لاالغاء الحمايه عن كافة الاوراق?", "الغاء الحماية", Type:=2) If pwd = "False" Then Exit Sub For Each ws In Worksheets ws.Unprotect Password:=pwd If ws.ProtectContents = True Then MsgBox "الباسورد غير صحيح لم يتم الغاء الحماية" Exit Sub End If Next ws End Sub مرفق ملف تجربه تحياتي كود حماية.rar

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

السلام عليكم اخي الفاضل في هذا الكود سوف يتم حذف الصنف من كل الاوراق انشاء الله يفي بالغرض Option Explicit Sub DeleteOnAllSheets() Dim ws As Worksheet Dim MatchWhole As Long Dim MyStr As String Dim strFIND As Range MyStr = Application.InputBox("ÇÏÎá ÇáÕäÝ ÇáãÑÇÏ ÍÐÝå ãä ßáÇ ÇáÇæÑÇÞ?", _ "ÈÍË Úä ÕäÝ", "123", Type:=2) If MyStr = "False" Or MyStr = vbNullString Then Exit Sub If MsgBox("åá ÇäÊ ãÊÃßÏ ãä ÇáÍÐÝ?" & vbLf & _ "(Ýí ÍÇáÉ ÚÏã ÇáÍÐÝ ÇÖÛØ ÒÑ áÇ", _ vbYesNo, "ÊÃßíÏ ÇáÍÐÝ?") = vbYes Then MatchWhole = 1 Else MatchWhole = 2 End If On Error Resume Next For Each ws In Worksheets Do Set strFIND = ws.Cells.Find(MyStr, LookIn:=xlValues, LookAt:=MatchWhole) If Not strFIND Is Nothing Then strFIND.EntireRow.Delete xlShiftUp Else Exit Do End If Loop Next ws End Sub السلام عليكم alidroos.ترحيل.rar

السلام عليكم الاخوة الافاضل هذا كود في حدث الصفحه عند الدخول المرئي من الورقة اخر الصفوف بمعنى لو الورقة فيها بيانات اذا لم يبرز التصريح لايمكنه رؤية مابداخل الورقة انشاء الله تستفيدو منه Option Explicit Private Sub Worksheet_Activate() Dim pwd As String: pwd = "123" Cells(Rows.Count, Columns.Count).Activate If Application.InputBox("برجاء ادخال التصريح لدخول الورقة?", "تصريح دخول الورقة", "???") <> pwd Then Sheets("ورقة2").Activate MsgBox "الباسورد خطاء غير مسموح لك دخول هذه الورقة", 0, "عفواً محضور الدخول" Else MsgBox "مرحبا بك", 32, "دخول ناجح" Range("A1").Activate End If End Sub الباسورد هو 123 ولتغيره من الكود في هذه الجزئية Dim pwd As String: pwd = "123" والسلام عليكم

الرفع كنت سهيت عن الموضوع مع تصفحي صادفته ههههه ارجو الافاده

السلام عليكم بعد اذن الاستاذ احمد فضيله ADMIN 111 USER 222 هذا والله اعلم

اطلعت على الملف لايوجد فيه سوى كمبوكس اخترت شهر اظهر حرف في التكست المقابل وليس به ماقلت ارجو ارفاق الملف كامل لكي يتم التعديل عليه

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

الاخ الفاضل يوسف عطا هل لك بشرح الطريقة فيديو نكون لك من الشاكرين

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

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

السلام عليكم الاستاذ عادل والاستاذ عبدالله مشكورين على هذا الابداع بارك الله فيكم دروس نتعلمها من اعمالكم