المشروع الكبير (مكتبة الصرح .. زاخرة بالشرح) وهي عبارة عن تجميع لمكتبة الأكواد

[Yasser Fathi Albanna]

كود إخفاء صيغ المعادلات ومنع حذفها

يوضع هذا الكود داخل 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). أيضا، إذا كنت ترغب في حذف هذا الماكرو من المصنف الخاص بك، سيكون لديك لإعادة إدخال كلمة المرور لإلغاء حماية المصنف بعد ذلك إذا كنت تريد أن يكون كل شيء دون وقاية.

 

مش عارف هل هذا هو المطلوب أخى ياسر أم لا

لأننى لا أعرف الشرح على الكود نفسة

[أ / محمد صالح]

مجهود رائع

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

وخاصة المهندس ياسر البنا

أرى فيه نبوغا ورغبة كبيرة في العلم وإفادة الغير

وفقنا الله وإياكم لكل ما يحبه ويرضاه

[ياسر خليل أبو البراء]

أخي الفاضل ياسر البنا

بوركت على الكود الخاص بحماية المعادلات .. وأنا غلطااااااااااان إني قلت لك ترجم هاته بالإنجليزي وأنا أترجمه ، لأن جوجل فاشل في الترجمة

ههههه متزعلش بهزر معاك .. بس ابقا ارفق النص الإنجليزي عشان أنا ضعيف في العربي شويتين

[ibn_egypt]

السلام عليكم

 

مرفق ملف به 3 أكواد مشروحة ... 

 

الأول: كود قراءة خصائص الأشكال الموجودة باى شيت وكتابة هذه الخصائص بشيت2

الثاني : كود ترتيب الشيتات بناءا على لون علامة التبويب لكل شيت .. المتشابهه في الالوان معا

الثالث : كود لعمل Index باسماء كل الشيتات والارتباطات بينها وبين الشيت الرئيسي

 

تحياتي  

 

3Codes-IbnEgypt.rar

[طارق محمود]

السلام عليكم

أخي الحبيب ياسر خليل

مازلت أشكرك علي الجهد المتميز ، وفقك الله وأعانك

أحببت أشارك ولو بشيء بسيط

هذا الكود لترتيب أوراق العمل تصاعديا أو تنازليا

طبعا جربته ، تمام

وبصراحة لم أتحقق إن كان موجود بمكتبتنا الرائعة أم لا

أضيف عليك هذا الجهد (التحقق من أنه موجود أم لا بالمكتبة)

مرفق ملف شرح

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

[ياسر خليل أبو البراء]

السلام عليكم ورحمة الله وبركاته

بعد طول غياب أقدم لكم إخواني الكرام إخواني الأحباب ، الإصدار الأخير من مكتبة الصرح ..

ورجاء أن تقوموا بتجربة الأكواد وإذا صادفتكم أي مشكلة من أي نوع رجاء الإبلاغ بها ، وإذا رأى منكم أحد أي خطأ في أي جزئية فليبادر بذكرها ، نريد تصحيح وتنقيح للعمل أولاً بأول

لكي يظهر في نهاية الأمر (دا إذا كان له نهاية أصلاً .............) لكي يظهر بشكل يليق بمكانة المنتدى العريق

ولكي ينفع به جموع المسلمين في كل مكان..

 

شكر خاص للأستاذ الكبير والأخ الغالي ابن مصر على إسهاماته

وشكر خاص للعلامة باشمهندس المنتدى طارق محمود ومن أكثر الناس محبة لقلبي

وشكر خاص لكل من ساهم في بناء المكتبة ولو بكلمة تشجيع

فالمكتبة منكم ولكم ، منكم ولكم ، وأؤكد منكم  ولكم

وفي الختام أسأل المولى أن يجعل أعمالنا صالحة ولوجهه خالصة وأن ينفع بنا وأن يجمعنا في الفردوس الأعلى من الجنة

إليكم الإصدار الأخير من مكتبة الصرح

 

Codes Library v1.9.rar

[Yasser Fathi Albanna]

مجهود رائع

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

وخاصة المهندس ياسر البنا

أرى فيه نبوغا ورغبة كبيرة في العلم وإفادة الغير

وفقنا الله وإياكم لكل ما يحبه ويرضاه

ألف ألف شكر أخى وأستاذى الفاضل / محمد صالح

يكفينى شرفا تشجيعك لى

جزاك الله خيرا

[Yasser Fathi Albanna]

أخي الفاضل ياسر البنا

بوركت على الكود الخاص بحماية المعادلات .. وأنا غلطااااااااااان إني قلت لك ترجم هاته بالإنجليزي وأنا أترجمه ، لأن جوجل فاشل في الترجمة

ههههه متزعلش بهزر معاك .. بس ابقا ارفق النص الإنجليزي عشان أنا ضعيف في العربي شويتين

أخى الفاضل وحبيبى الأستاذ / ياسر خليل

شكرا لك ولتشجيعك لى أيضا فأنت أخ أعتذ به

[الجموعي]

السلام عليكم أستاذي /ياسر

كود إنشاء صفحة ومعرفة إن كانت مكررة أم لا

المتطلبات:

يوزر فورم

مربع نص نسمية 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

[ياسر خليل أبو البراء]

بارك الله فيك أخي الجموعي على هذه الأكواد الرائعة

بعد التجربة قمت بتغيير هذا السطر فقط لتجنب وقوع خطأ

If LCase(SheetNewName.Text) = LCase(Worksheets(I).Name) Then

فعند تجربة الكود قمت بكتابة كلمة Data في مربع النص فتم إنشاء الصفحة ، وعند كتابتها مرة أخرى ظهرت رسالة التنبيه ، وعند كتابتها بالحروف الصغيرة data ظهرت رسالة خطأ

يرجى إعادة تجربة الكود قبل التعديل وبعد التعديل للتأكد من صحة ما قلت

تقبل تحياتي

[الجموعي]

بارك الله فيك أخي الجموعي على هذه الأكواد الرائعة

بعد التجربة قمت بتغيير هذا السطر فقط لتجنب وقوع خطأ

If LCase(SheetNewName.Text) = LCase(Worksheets(I).Name) Then

فعند تجربة الكود قمت بكتابة كلمة Data في مربع النص فتم إنشاء الصفحة ، وعند كتابتها مرة أخرى ظهرت رسالة التنبيه ، وعند كتابتها بالحروف الصغيرة data ظهرت رسالة خطأ

يرجى إعادة تجربة الكود قبل التعديل وبعد التعديل للتأكد من صحة ما قلت

تقبل تحياتي

 كلامك مضبوط أستاذي

معذرة مني لأني قمت بتجريب الكود من قبل بالأسماء العربية والارقام والأسماء باللغة اللاتنية فقط بالحروف الصغيرة

أعتزر مره ثانية

وشكرا على التعديل وجزاك الله كل الخير

[ياسر خليل أبو البراء]

أخي الغالي الجموعي

لا داعي أبدا للاعتذار .. فالخطأ مقبول ...وأنت لم تخطيء بالأساس إنما هي غلاسة مني

أنا اللي بدقق زيادة عن اللازم عشان يكون الكود مضبوط بقدر الإمكان عشان اللي هيستخدمه ميواجهش أي مشكلة

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

ومتحرمناش من روائعك يا جموعي .. يعجبني جدا أسلوبك في الشرح واختيارك للأكواد

تقبل تحياتي

[ابو تراب]

كود لاستخلاص حرف/حروف او اسم العمود من عنوان الخلية

 

مثال مرفق للتوضيح

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

[ياسر خليل أبو البراء]

بارك الله فيك أخي الغالي أبو تراب

أكواد ودوال مميزة من شخص متميز .. ربنا ميحرمناش منك ويخليك للغلابة ..

نطمع في المزيد ...

لا تنعتني بالطماع ، لأني طماع بطبعي Greedy Very Greedy>>

I'm Greedy Mr. Haridy .. Who's Mr. Haridy

تقبل تحياتي

[ابو تراب]

كود لحذف الاسطر المكررة

 

شرح مختصر للكود

 

الفكرة هى فحص السطر كاملا (و ليس خلية بخلية) عن طريق الدالة 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

[ابو تراب]

بارك الله فيك أخي الغالي أبو تراب

أكواد ودوال مميزة من شخص متميز .. ربنا ميحرمناش منك ويخليك للغلابة ..

نطمع في المزيد ...

لا تنعتني بالطماع ، لأني طماع بطبعي Greedy Very Greedy>>

I'm Greedy Mr. Haridy .. Who's Mr. Haridy

 

تقبل تحياتي

 

هلا و غلا باخي و استاذنا ياسر ...شكر الله لك كلماتك الطيبة

 

ولا يهمك اي فكرة او معلومة ان شاء الله نشارك بها في المنتدى الغالي

 

  .Mr. Haridy  لسة ما تعرفنا عليه    

[ياسر خليل أبو البراء]

جزيل الشكر لك أخي الحبيب أبو تراب

يوجد بالمكتبة كود بسيط جدا يقوم بنفس المهمة ، مفتاح البحث [حذف] أو [إزالة] ..
 

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
وعموما سيتم إضافة رائعتك أيضاً لإثراء المكتبة بحلول وأكواد مختلفة

[KHMB]

السلام عليكم ورحمة الله

شكرا ابو تراب  وانت فعلا مثل ماقال اخونا الطيب ياسر خليل ابو الذهب ولك الفخر بـ ابا تراب  وهو اللقب من سيد البشر وخير خلق الله سيدنا محمد صلى اله عليه وعلى آله واصحابه اجمعين لرابع الخلفاء الراشدين سيدنا علي كرم الله وجهه.

فعلا االواثق من عملك بدعم وشرح كل كود بمثـــــــــــــــــــــــــــــــــــــــــــــــــــــال مشكور وجزاك الله خير

انا متابع كل عمل لك

تم تعديل يناير 15, 2015 بواسطه KHMB

[KHMB]

السلام عليكم ورحمة الله

اخي الطيب ياسر خليل الكود البسيط لم يعمل معي

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

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

يا يا يا يا طمًــــــــــــــــــــــــــــــــــــــــاع

تم تعديل يناير 15, 2015 بواسطه KHMB

[ياسر خليل أبو البراء]

الأخوة الكرام .. إليكم الإصدار الجديد من المكتبة ..

الأخ خالد الغالي أبا الحسن والحسين

ابحث في مكتبة الصرح عن كلمة [إزالة] ستجد أكواد حذف الصفوف المكررة .. اطلع على الشرح أولاً واقرأ الشرح جيداً .. بالنسبة للكود الأول يتم تحديد عدد الأعمدة من خلال مصفوفة من 1 إلى 9 أي من العمود رقم 1 إلى العمود رقم 9 ، أي لكي يعمل معك الكود لابد من التعديل قليلاً عليه ، وإذا قابلتك أي مشكلة أبلغني في الحال

 

Codes Library v1.9.1.rar

[ابو تراب]

 

جزيل الشكر لك أخي الحبيب أبو تراب

يوجد بالمكتبة كود بسيط جدا يقوم بنفس المهمة ، مفتاح البحث [حذف] أو [إزالة] ..

 

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

[ابو تراب]

السلام عليكم ورحمة الله

شكرا ابو تراب  وانت فعلا مثل ماقال اخونا الطيب ياسر خليل ابو الذهب ولك الفخر بـ ابا تراب  وهو اللقب من سيد البشر وخير خلق الله سيدنا محمد صلى اله عليه وعلى آله واصحابه اجمعين لرابع الخلفاء الراشدين سيدنا علي كرم الله وجهه.

فعلا االواثق من عملك بدعم وشرح كل كود بمثـــــــــــــــــــــــــــــــــــــــــــــــــــــال مشكور وجزاك الله خير

انا متابع كل عمل لك

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

 

نسال الله من لا تطيب الدنيا الا بذكره القبول لنا و لكم و جميع المسلمين

 

وصلى الله على سيدنا محمد قرة اعيينا و رضي الله عن ساداتنا ابوبكر و عمر و عثمان و علي كرم الله وجهه

[ياسر خليل أبو البراء]

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

أريد منك العمل على القائمة المنسدلة المتناقصة !! Decreasing Validation List .. لم أجد إلى الآن حل يرضيني

وجدت بعض الحلول ولكنها غير مرضية أرجو أن نتوصل لحل إن شاء الله

[KHMB]

السلام عليكم ورحمة الله

يا ابو البراء بالاصرار والعزيمة حتوصلوا ان شاء الله الله يعينكم

تم تعديل يناير 15, 2015 بواسطه KHMB

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

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

إليكم الإصدار الأخير (هدوخكم ورايا)

Codes Library v1.9.2.rar

تم تعديل يناير 15, 2015 بواسطه YasserKhalil