Yasser Fathi Albanna قام بنشر يناير 13, 2015 قام بنشر يناير 13, 2015 كود إخفاء صيغ المعادلات ومنع حذفها يوضع هذا الكود داخل ThisWorkbook Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Dim formula As Range On Error Resume Next Sh.Unprotect Password:="password" With Selection .Locked = False .FormulaHidden = False End With If Target.Cells.Count = 1 Then If Target.HasFormula Then With Target .Locked = True .FormulaHidden = True End With Sh.Protect Password:="password", UserInterFaceOnly:=True End If ElseIf Target.Cells.Count > 1 Then Set formula = Selection.SpecialCells(xlCellTypeFormulas) If Not formula Is Nothing Then With Selection.SpecialCells(xlCellTypeFormulas) .Locked = True .FormulaHidden = True End With Sh.Protect Password:="password", UserInterFaceOnly:=True End If End If On Error GoTo 0 End Sub وهذا شرح مترجم للكود هذا الماكرو إخفاء كل الصيغ في مصنف وعدم السماح لهم ليتم حذفها. لن تكون محمية الصفحة مثل ورقة عمل محمية العادية في التفوق؛ هذا يعني أنه ما زال بإمكانك إضافة المحتوى إلى المصنف دون مشكلة ويمكنك تعديل كل شيء طالما أنها ليست الصيغة. يمكنك إدخال صيغة جديدة ولكن لا يمكنك ثم حذف تلك الصيغة. وبالإضافة إلى ذلك، إذا قمت بتحديد خلية تحتوي على الصيغة، لن يتم عرض محتويات تلك الخلية. هذا يسمح لك للحفاظ على الصيغ مخفية عن المستخدمين ويضيف مستوى إضافي من الأمن. إذا كنت ترغب في تعديل خلية معينة، سيكون لديك للنقر تلك الخلية ثم "إظهار" تلك الخلية عن طريق كتابة كلمة المرور (الذي يقع في رمز VBA). أيضا، إذا كنت ترغب في حذف هذا الماكرو من المصنف الخاص بك، سيكون لديك لإعادة إدخال كلمة المرور لإلغاء حماية المصنف بعد ذلك إذا كنت تريد أن يكون كل شيء دون وقاية. مش عارف هل هذا هو المطلوب أخى ياسر أم لا لأننى لا أعرف الشرح على الكود نفسة 1
أ / محمد صالح قام بنشر يناير 13, 2015 قام بنشر يناير 13, 2015 مجهود رائع جزاكم الله كل خير جميعا وبلا استثناء وخاصة المهندس ياسر البنا أرى فيه نبوغا ورغبة كبيرة في العلم وإفادة الغير وفقنا الله وإياكم لكل ما يحبه ويرضاه 3
ياسر خليل أبو البراء قام بنشر يناير 13, 2015 الكاتب قام بنشر يناير 13, 2015 أخي الفاضل ياسر البنا بوركت على الكود الخاص بحماية المعادلات .. وأنا غلطااااااااااان إني قلت لك ترجم هاته بالإنجليزي وأنا أترجمه ، لأن جوجل فاشل في الترجمة ههههه متزعلش بهزر معاك .. بس ابقا ارفق النص الإنجليزي عشان أنا ضعيف في العربي شويتين 1
ibn_egypt قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 السلام عليكم مرفق ملف به 3 أكواد مشروحة ... الأول: كود قراءة خصائص الأشكال الموجودة باى شيت وكتابة هذه الخصائص بشيت2 الثاني : كود ترتيب الشيتات بناءا على لون علامة التبويب لكل شيت .. المتشابهه في الالوان معا الثالث : كود لعمل Index باسماء كل الشيتات والارتباطات بينها وبين الشيت الرئيسي تحياتي 3Codes-IbnEgypt.rar 1
طارق محمود قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 السلام عليكم أخي الحبيب ياسر خليل مازلت أشكرك علي الجهد المتميز ، وفقك الله وأعانك أحببت أشارك ولو بشيء بسيط هذا الكود لترتيب أوراق العمل تصاعديا أو تنازليا طبعا جربته ، تمام وبصراحة لم أتحقق إن كان موجود بمكتبتنا الرائعة أم لا أضيف عليك هذا الجهد (التحقق من أنه موجود أم لا بالمكتبة) مرفق ملف شرح Sub Sort_Worksheets() Dim i As Integer, j As Integer, Ansr As VbMsgBoxResult Ansr = MsgBox("تريد ترتيب الشيتات تصاعديا ؟" & Chr(10) & "بضغط (لا) سيتم الترتيب تنازليا", _ vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets") For i = 1 To Sheets.Count For j = 1 To Sheets.Count - 1 If Ansr = vbYes Then If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then Sheets(j).Move After:=Sheets(j + 1) ElseIf Ansr = vbNo Then If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then Sheets(j).Move After:=Sheets(j + 1) End If Next j Next i End Sub هذا الكود ضمن أكثر من مائة كود علي الرابط http://www.teachexcel.com/free-excel-macros/ أنا فقط عدلت في الشكل ونص السؤال بالعربية بدلا من الإنجليزيةومن هذا الرابط أيضا يمكن إقتباس فكرة ضم الأكواد في مجموعات أو عناوين كبيرة شرح الكود ترتيب أسماء الورقات.rar 1 1
ياسر خليل أبو البراء قام بنشر يناير 14, 2015 الكاتب قام بنشر يناير 14, 2015 السلام عليكم ورحمة الله وبركاته بعد طول غياب أقدم لكم إخواني الكرام إخواني الأحباب ، الإصدار الأخير من مكتبة الصرح .. ورجاء أن تقوموا بتجربة الأكواد وإذا صادفتكم أي مشكلة من أي نوع رجاء الإبلاغ بها ، وإذا رأى منكم أحد أي خطأ في أي جزئية فليبادر بذكرها ، نريد تصحيح وتنقيح للعمل أولاً بأول لكي يظهر في نهاية الأمر (دا إذا كان له نهاية أصلاً .............) لكي يظهر بشكل يليق بمكانة المنتدى العريق ولكي ينفع به جموع المسلمين في كل مكان.. شكر خاص للأستاذ الكبير والأخ الغالي ابن مصر على إسهاماته وشكر خاص للعلامة باشمهندس المنتدى طارق محمود ومن أكثر الناس محبة لقلبي وشكر خاص لكل من ساهم في بناء المكتبة ولو بكلمة تشجيع فالمكتبة منكم ولكم ، منكم ولكم ، وأؤكد منكم ولكم وفي الختام أسأل المولى أن يجعل أعمالنا صالحة ولوجهه خالصة وأن ينفع بنا وأن يجمعنا في الفردوس الأعلى من الجنة إليكم الإصدار الأخير من مكتبة الصرح Codes Library v1.9.rar 2
Yasser Fathi Albanna قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 مجهود رائع جزاكم الله كل خير جميعا وبلا استثناء وخاصة المهندس ياسر البنا أرى فيه نبوغا ورغبة كبيرة في العلم وإفادة الغير وفقنا الله وإياكم لكل ما يحبه ويرضاه ألف ألف شكر أخى وأستاذى الفاضل / محمد صالح يكفينى شرفا تشجيعك لى جزاك الله خيرا
Yasser Fathi Albanna قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 أخي الفاضل ياسر البنا بوركت على الكود الخاص بحماية المعادلات .. وأنا غلطااااااااااان إني قلت لك ترجم هاته بالإنجليزي وأنا أترجمه ، لأن جوجل فاشل في الترجمة ههههه متزعلش بهزر معاك .. بس ابقا ارفق النص الإنجليزي عشان أنا ضعيف في العربي شويتين أخى الفاضل وحبيبى الأستاذ / ياسر خليل شكرا لك ولتشجيعك لى أيضا فأنت أخ أعتذ به
الجموعي قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 السلام عليكم أستاذي /ياسر كود إنشاء صفحة ومعرفة إن كانت مكررة أم لا المتطلبات: يوزر فورم مربع نص نسمية SheetNewName زر تحكم نسمية Cmd_NewSheet Private Sub Cmd_NewSheet_Click() Dim i As Integer ' إعلان متغير i عدد صحيح For i = 1 To Worksheets.Count 'متغير i تساوي من ورقة العمل 1 إلى اخر أوراق العمل ' تفحص ما اذا كان اسم ورقة موجود أم لا If SheetNewName.Text = Worksheets(i).Name Then ' إذا كانت القيمة في مربع النص تساوي إسم ورقة من أوراق العمل MsgBox "إسم الصفحة موجود مسبقا, يرجى إختيار إسم أخر", vbOKOnly + vbCritical, "تنبيه" Exit Sub ' إنهاء الإجراء End If 'إنهاءالشرط Next ' التالي 'إنشاء ورقة عمل جديدة بعد أخر ورقه عمل موجودة Sheets.Add After:=Sheets(Sheets.Count) 'تسمية ورقة العمل الجديدة بإسم القيمة المدرجة في مربع النص Sheets(Sheets.Count).Name = SheetNewName.Text 'تصفير البيانات في مربع النص SheetNewName.Value = "" End Sub
ياسر خليل أبو البراء قام بنشر يناير 14, 2015 الكاتب قام بنشر يناير 14, 2015 بارك الله فيك أخي الجموعي على هذه الأكواد الرائعة بعد التجربة قمت بتغيير هذا السطر فقط لتجنب وقوع خطأ If LCase(SheetNewName.Text) = LCase(Worksheets(I).Name) Then فعند تجربة الكود قمت بكتابة كلمة Data في مربع النص فتم إنشاء الصفحة ، وعند كتابتها مرة أخرى ظهرت رسالة التنبيه ، وعند كتابتها بالحروف الصغيرة data ظهرت رسالة خطأ يرجى إعادة تجربة الكود قبل التعديل وبعد التعديل للتأكد من صحة ما قلت تقبل تحياتي 1
الجموعي قام بنشر يناير 14, 2015 قام بنشر يناير 14, 2015 بارك الله فيك أخي الجموعي على هذه الأكواد الرائعة بعد التجربة قمت بتغيير هذا السطر فقط لتجنب وقوع خطأ If LCase(SheetNewName.Text) = LCase(Worksheets(I).Name) Then فعند تجربة الكود قمت بكتابة كلمة Data في مربع النص فتم إنشاء الصفحة ، وعند كتابتها مرة أخرى ظهرت رسالة التنبيه ، وعند كتابتها بالحروف الصغيرة data ظهرت رسالة خطأ يرجى إعادة تجربة الكود قبل التعديل وبعد التعديل للتأكد من صحة ما قلت تقبل تحياتي كلامك مضبوط أستاذي معذرة مني لأني قمت بتجريب الكود من قبل بالأسماء العربية والارقام والأسماء باللغة اللاتنية فقط بالحروف الصغيرة أعتزر مره ثانية وشكرا على التعديل وجزاك الله كل الخير
ياسر خليل أبو البراء قام بنشر يناير 14, 2015 الكاتب قام بنشر يناير 14, 2015 أخي الغالي الجموعي لا داعي أبدا للاعتذار .. فالخطأ مقبول ...وأنت لم تخطيء بالأساس إنما هي غلاسة مني أنا اللي بدقق زيادة عن اللازم عشان يكون الكود مضبوط بقدر الإمكان عشان اللي هيستخدمه ميواجهش أي مشكلة عشان كدا باخد وقت كبير في وضع الكود لأني بجربه من جميع الاتجاهات بقدر الإمكان ومتحرمناش من روائعك يا جموعي .. يعجبني جدا أسلوبك في الشرح واختيارك للأكواد تقبل تحياتي
ابو تراب قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 كود لاستخلاص حرف/حروف او اسم العمود من عنوان الخلية مثال مرفق للتوضيح Public Function GetColumnLetter(Cell As Range) As String Const NOT_SINGLE_CELL As Long = vbObjectError + 1001 Dim ColLetter As String ' تأكد ان المدى يمثل خلية واحدة فقط If Cell.Count > 1 Then GetColumnLetter = CVErr(NOT_SINGLE_CELL): Exit Function ' استخلص اسم العمود من عنوان الخلية ColLetter = Cells(1, Cell.Column).Address ColLetter = Replace(Replace(ColLetter, "$", ""), "1", "") GetColumnLetter = ColLetter End Function استخلص اسم العمود Get Column letter char.zip 1
ياسر خليل أبو البراء قام بنشر يناير 15, 2015 الكاتب قام بنشر يناير 15, 2015 بارك الله فيك أخي الغالي أبو تراب أكواد ودوال مميزة من شخص متميز .. ربنا ميحرمناش منك ويخليك للغلابة .. نطمع في المزيد ... لا تنعتني بالطماع ، لأني طماع بطبعي Greedy Very Greedy>> I'm Greedy Mr. Haridy .. Who's Mr. Haridy تقبل تحياتي 1
ابو تراب قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 كود لحذف الاسطر المكررة شرح مختصر للكود الفكرة هى فحص السطر كاملا (و ليس خلية بخلية) عن طريق الدالة Join بما ان الدالة Join تقبل مصفوفة ذات بعد واحد و في نفس الوقت فان الكائن range يعيد مصفوفة دات بعدين البعد الاول هو من 1 الى 1 و البعد الثاني هو من 1 الى عدد الاعمدة في المدى هنا لتمرير بعد واحد فقط يمكننا استخدام الدالة Transpose. فللاعمدة يمكننا تمرير الدالة Transpose مرة و احدة بينما للاسطر فنحتاج لتمريرها مرتين Sub btnRemoveDuplicates() Const FirstRow As Long = 1 Dim LastRow As Long Dim LastColChr As String Dim Addr1 As String Dim Addr2 As String Dim i As Long Dim j As Long ' احصل على رقم الصف الاخير للجدول LastRow = Range("A" & Rows.Count).End(xlUp).Row ' استخلص اسم العمود الاخير للجدول LastColChr = Cells(1, Columns.Count).End(xlToLeft).Address LastColChr = Replace(Replace(LastColChr, "$", ""), "1", "") If Range("A1:" & LastColChr & LastRow).Rows.Count > 2 ^ 16 Then Exit Sub With Application For i = FirstRow To LastRow - 1 ' حدث عنوان السطر الحالي Addr1 = "A" & i & ":" & LastColChr & i ' حدث عنوان السطر التالي For j = i + 1 To LastRow Addr2 = "A" & j & ":" & LastColChr & j ' افحص تطابق السطرين If Join(.Transpose(.Transpose(ActiveSheet.Range(Addr1).Value)), Chr(0)) = _ Join(.Transpose(.Transpose(ActiveSheet.Range(Addr2).Value)), Chr(0)) Then ' احذف السطر و عد حسابات ابعاد الجدول Range(Addr2).Delete xlShiftUp j = j - 1 LastRow = Range("A" & Rows.Count).End(xlUp).Row End If Next j Next i End With End Sub Remove Duplicates حذف الاسطر المكررة.zip 1
ابو تراب قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 بارك الله فيك أخي الغالي أبو تراب أكواد ودوال مميزة من شخص متميز .. ربنا ميحرمناش منك ويخليك للغلابة .. نطمع في المزيد ... لا تنعتني بالطماع ، لأني طماع بطبعي Greedy Very Greedy>> I'm Greedy Mr. Haridy .. Who's Mr. Haridy تقبل تحياتي هلا و غلا باخي و استاذنا ياسر ...شكر الله لك كلماتك الطيبة ولا يهمك اي فكرة او معلومة ان شاء الله نشارك بها في المنتدى الغالي .Mr. Haridy لسة ما تعرفنا عليه 1
ياسر خليل أبو البراء قام بنشر يناير 15, 2015 الكاتب قام بنشر يناير 15, 2015 جزيل الشكر لك أخي الحبيب أبو تراب يوجد بالمكتبة كود بسيط جدا يقوم بنفس المهمة ، مفتاح البحث [حذف] أو [إزالة] .. Sub DeleteDuplicateRows() Dim Rng As Range 'بدء التعامل مع ورقة العمل النشطة With ActiveSheet 'تعيين النطاق المراد العمل عليه من العمود الأول إلى العمود التاسع Set Rng = Range("A1", Range("D1").End(xlDown)) 'إزالة الصفوف المكررة ، من خلال مصفوفة الأعمدة من العمود رقم 1 إلى العمود رقم 9 Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo End With End Sub وعموما سيتم إضافة رائعتك أيضاً لإثراء المكتبة بحلول وأكواد مختلفة 1
KHMB قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 (معدل) السلام عليكم ورحمة الله شكرا ابو تراب وانت فعلا مثل ماقال اخونا الطيب ياسر خليل ابو الذهب ولك الفخر بـ ابا تراب وهو اللقب من سيد البشر وخير خلق الله سيدنا محمد صلى اله عليه وعلى آله واصحابه اجمعين لرابع الخلفاء الراشدين سيدنا علي كرم الله وجهه. فعلا االواثق من عملك بدعم وشرح كل كود بمثـــــــــــــــــــــــــــــــــــــــــــــــــــــال مشكور وجزاك الله خير انا متابع كل عمل لك تم تعديل يناير 15, 2015 بواسطه KHMB 2
KHMB قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 (معدل) السلام عليكم ورحمة الله اخي الطيب ياسر خليل الكود البسيط لم يعمل معي ممكن تدعمه بمثال وجزاك الله خير اخي ياسر كنت متابع كل عملك من عام وانقطعت ثم رجعت بزخم 2009 جزاك الله خير يا يا يا يا طمًــــــــــــــــــــــــــــــــــــــــاع تم تعديل يناير 15, 2015 بواسطه KHMB 1
ياسر خليل أبو البراء قام بنشر يناير 15, 2015 الكاتب قام بنشر يناير 15, 2015 الأخوة الكرام .. إليكم الإصدار الجديد من المكتبة .. الأخ خالد الغالي أبا الحسن والحسين ابحث في مكتبة الصرح عن كلمة [إزالة] ستجد أكواد حذف الصفوف المكررة .. اطلع على الشرح أولاً واقرأ الشرح جيداً .. بالنسبة للكود الأول يتم تحديد عدد الأعمدة من خلال مصفوفة من 1 إلى 9 أي من العمود رقم 1 إلى العمود رقم 9 ، أي لكي يعمل معك الكود لابد من التعديل قليلاً عليه ، وإذا قابلتك أي مشكلة أبلغني في الحال Codes Library v1.9.1.rar 1
ابو تراب قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 جزيل الشكر لك أخي الحبيب أبو تراب يوجد بالمكتبة كود بسيط جدا يقوم بنفس المهمة ، مفتاح البحث [حذف] أو [إزالة] .. Sub DeleteDuplicateRows() Dim Rng As Range 'بدء التعامل مع ورقة العمل النشطة With ActiveSheet 'تعيين النطاق المراد العمل عليه من العمود الأول إلى العمود التاسع Set Rng = Range("A1", Range("D1").End(xlDown)) 'إزالة الصفوف المكررة ، من خلال مصفوفة الأعمدة من العمود رقم 1 إلى العمود رقم 9 Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo End With End Sub وعموما سيتم إضافة رائعتك أيضاً لإثراء المكتبة بحلول وأكواد مختلفة جزاك الله خيرا على هذه الاجراء المختصر فعلا. تجدر الملاحظة ان الاجراء RemoveDuplicates يزيل الاسطر المكررة بدون حذفها على العموم كتبت اجراء جديد مستفيدا من ماتفضلت به بحيث يصبح عام قدر الامكان بدون التقيد بابعاد الجدول لا ادري اذا كان من الافضل اضافة هذا الاجراء الى المكتبة او الحفاظ على بساطة الفكرة ووضوحها .. اترك القرار لك. تقبل شكري و تقديري مرفق مثال للتجريب Public Sub RemoveDuplicates(StartCell As Range, Optional Header As Boolean = False) Dim Table As Range Dim TotalCols As Long Dim ColArray As Variant Dim Col As Long If StartCell.Count > 1 Then Exit Sub Set Table = StartCell.CurrentRegion TotalCols = Table.Columns.Count ReDim ColArray(0 To TotalCols - 1) For Col = 1 To TotalCols ColArray(Col - 1) = Col Next Application.ScreenUpdating = False If Header Then Table.RemoveDuplicates Columns:=(ColArray), Header:=xlYes Else Table.RemoveDuplicates Columns:=(ColArray), Header:=xlNo End If Application.ScreenUpdating = True End Sub Remove Duplicates اجراء عام لازالة الاسطر المكررة.zip 1
ابو تراب قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 السلام عليكم ورحمة الله شكرا ابو تراب وانت فعلا مثل ماقال اخونا الطيب ياسر خليل ابو الذهب ولك الفخر بـ ابا تراب وهو اللقب من سيد البشر وخير خلق الله سيدنا محمد صلى اله عليه وعلى آله واصحابه اجمعين لرابع الخلفاء الراشدين سيدنا علي كرم الله وجهه. فعلا االواثق من عملك بدعم وشرح كل كود بمثـــــــــــــــــــــــــــــــــــــــــــــــــــــال مشكور وجزاك الله خير انا متابع كل عمل لك حياك الله اخي الغالي الاستاذ KHMB و شكر الله لك على كلماتك المشجعة و متابعتك ما نقدمه لاشئ مما يقدم من اساتذتنا الافاضل والاعضاء الكرام نسال الله من لا تطيب الدنيا الا بذكره القبول لنا و لكم و جميع المسلمين وصلى الله على سيدنا محمد قرة اعيينا و رضي الله عن ساداتنا ابوبكر و عمر و عثمان و علي كرم الله وجهه 1
ياسر خليل أبو البراء قام بنشر يناير 15, 2015 الكاتب قام بنشر يناير 15, 2015 بارك الله فيك أخي أبو تراب .. وجزيت خيراً على هذا الإبداع اللامتناهي .. أريد منك العمل على القائمة المنسدلة المتناقصة !! Decreasing Validation List .. لم أجد إلى الآن حل يرضيني وجدت بعض الحلول ولكنها غير مرضية أرجو أن نتوصل لحل إن شاء الله 1
KHMB قام بنشر يناير 15, 2015 قام بنشر يناير 15, 2015 (معدل) السلام عليكم ورحمة الله يا ابو البراء بالاصرار والعزيمة حتوصلوا ان شاء الله الله يعينكم تم تعديل يناير 15, 2015 بواسطه KHMB 2
ياسر خليل أبو البراء قام بنشر يناير 15, 2015 الكاتب قام بنشر يناير 15, 2015 (معدل) الحمد لله الذي بنعمته تتم الصالحات قررت أن أتابع الإصدار أولاً بأول حتى يتسنى لمن يريد المشاركة الإطلاع على المكتبة و البحث عن الكود الذي سيقوم بإدراجه أولاً فإذا وجد نفس الكود فلا يتم المشاركة به مرة أخرى ، ولو وجد نفس الموضوع ولكن لديه كود آخر فليتقدم به ، فنحن نريد إثراء المكتبة بالحلول المختلفة للموضوع الواحد إليكم الإصدار الأخير (هدوخكم ورايا) Codes Library v1.9.2.rar تم تعديل يناير 15, 2015 بواسطه YasserKhalil 2
الردود الموصى بها