إجمالي مرات مشاهدة الصفحة

الخميس، 26 مايو 2016

إرجاع نتائج متعددة بشرط واحد في نطاق Concatenate Data With Single Criteria

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

أقدم لكم دالة معرفة User-Defined Function تقوم بالبحث في نطاق عن شرط محدد ، ثم تقوم بإرجع القيم المقابلة لهذا النطاق في أي عمود آخر ، أي أن الدالة ترجع قيم متعددة ، ويكون الناتج في خلية واحدة فقط

بفرض أن لديك مجموعة مواد دراسية في العمود الأول ، وفي العمود الثالث القيمة 1 في حالة النجاح والقيمة صفر في حالة الرسوب ، والمطلوب إضافة وتجميع مواد الرسوب في خلية واحدة

خطوات الحل :
------------
قم بوضع الدالة المعرفة في موديول عادي بهذا الشكل :

Function Concat(a As Variant, Optional sep As String = "") As String
    Dim y As Variant

    If TypeOf a Is Range Then
        For Each y In a.Cells
            Concat = Concat & y.Value & sep
        Next y
    ElseIf IsArray(a) Then
        For Each y In a
            Concat = Concat & y & sep
        Next y
    Else
        Concat = Concat & a & sep
    End If

    Concat = Left(Concat, Len(Concat) - Len(sep))
End Function

في أي خلية وليكن الخلية A14 ضع المعادلة التالية (معادلة صفيف أي يجب الضغط على Ctrl + Shift + Enter)

=SUBSTITUTE(Concat(IF(C2:C11=0," * "&A2:A11,""))," * ","",1)

المعادلة تقوم بتجميع مواد الرسوب باستخدام الدالة المعرفة Concat ، ويمثل النطاق C2:C11 النطاق الذي يحتوي الشرط المطلوب اختباره والشرط هنا في المثال أن تكون قيمة الخلية في النطاق تساوي صفر .. ويمثل النطاق B2:B11 النطاق الذي سيتم جلب البيانات أو النتائج منه وهي هنا في المثال مواد الرسوب
يمكن استخدام أي فاصل في النتائج بخلاف علامة النجمة المستخدمة كما يحلو لك ، فقط قم بتغيير الفاصلة (علامة النجمة) إلى الفاصلة التي ترغب فيها ، في المعادلة السابقة (سيكون التغيير للفاصلة في موضعين)



 إعداد / ياسر خليل أبو البراء

الاثنين، 23 مايو 2016

إجبار المستخدم على تفعيل الماكرو Force User To Enable Macros

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


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

لابد أولاً أن تعرف كيف يمكنك تفعيل الماكرو أو تعطيله .. يحدث ذلك من خلال التبويب Developer ثم Macro Security  كما بالصورة التالية 
يمكن تعطيل الماكرو من خلال أول خيار بالنافذة ، أو تفعيله من خلال آخر خيار بالنافذة

خطوات العمل :
أولاً : قم بإنشاء ورقة عمل جديدة في المصنف الخاص بك وأعطها أي اسم وليكن Warning (إذا أردت أن تسمي الورقة باسم آخر فقم بالتعديل في الكود في أول سطر منه فقط)

ثانياً : ضع في ورقة العمل التحذيرية جملة أو صورة أو ما يحلو لك ، كنوع من التنبيه للمستخدم في حالة عدم تمكين الماكرو (كما في الملف المرفق وضحت في الصورة أنه يجب على المستخدم تمكين الماكرو لكي يفتح المصنف)

ثالثاً : وأخيراً ضع الكود التالي في حدث المصنف (الذهاب لمحرر الأكواد عن طريق Alt + F11 ثم انقر دبل كليك في حدث المصنف ThisWorkbook ثم الصق الكود التالي

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

'قم بتعيين اسم ورقة العمل التحذيرية
Const Warning As String = "Warning"

Private Sub Workbook_Open()
    Dim Ws As Worksheet

    Application.ScreenUpdating = False
        For Each Ws In ThisWorkbook.Worksheets
            Ws.Visible = xlSheetVisible
        Next Ws
    
        Sheets(Warning).Visible = xlVeryHidden
    Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim Ws As Worksheet

    Application.ScreenUpdating = False
        Sheets(Warning).Visible = xlSheetVisible
    
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> Warning Then
                Ws.Visible = xlVeryHidden
            End If
        Next Ws
    Application.ScreenUpdating = True

    ActiveWorkbook.Save
End Sub

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

إعداد / ياسر خليل أبو البراء

الخميس، 19 مايو 2016

إنشاء نسخة احتياطي من المصنف (حفظ تلقائي) كل فترة زمنية محددة Backup Automatically Every 15 Seconds

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

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

الكود يقوم بإنشاء النسخة الاحتياطية في نفس مسار المصنف الحالي في مجلد باسم Test ، ويتم إنشاء المجلد بشكل تلقائي إذا لم يكن موجود ، ويمكنك تغيير مسار الحفظ التلقائي ، ويمكنك تغيير اسم المجلد المطلوب حفظ النسخ الاحتياطية فيه ، كما يمكنك تغيير الفترة الزمنية المطلوبة لعملية الحفظ التلقائي (الكود مشروح بالتفصيل كي يسهل عليك مهمة التعديل عليه)

وأخيراً إليكم الكود ، وهو مكون من كود يوضع في موديول عادي بهذا الشكل

Sub Create_Backup()
    'تعريف المتغيرات
    Dim strDate As String, strTime As String, directoryName As String

    'تنسيق التاريخ
    strDate = Format(Date, "DD-MM-YYYY")

    'تنسيق الوقت
    strTime = Format(Time, "hh.mm.ss")

    'إلغاء خاصية رسائل التنبيه
    Application.DisplayAlerts = False

        'بدء التعامل مع المصنف النشط
        With ActiveWorkbook
            On Error Resume Next
                '[Test] المسار الذي سيتم حفظ النسخة فيه وهو نفس مسار المصنف الحالي في مجلد باسم
                directoryName = ThisWorkbook.Path & "\Test\"
        
                'إنشاء المجلد الذي سيتم وضع النسخ الاحتياطية فيه إذا لم يكن موجود
                MkDir directoryName
            On Error GoTo 0
    
            'حفظ نسخة من المصنف بالتاريخ والوقت الحاليين
            .SaveCopyAs Filename:=directoryName & strDate & "_" & strTime & "_" & .Name
        End With

    'إعادة تفعيل خاصية رسائل التنبيه
    Application.DisplayAlerts = True

    'سطر يقوم بتنفيذ الماكرو مرة أخرى بعد الوقت المحدد في السطر
    Application.OnTime Now + TimeValue("00:00:15"), "Create_Backup"
End Sub

والجزء الثاني من الكود يوضع في حدث المصنف بهذا الشكل

Private Sub Workbook_Open()
    'بعد مرور الوقت المحدد في السطر [CreateBackup] يقوم هذا السطر بتنفيذ الماكرو المسمى
    Application.OnTime Now + TimeValue("00:00:15"), "Create_Backup"
End Sub
إعداد / ياسر خليل أبو البراء

الثلاثاء، 10 مايو 2016

عكس القيم في صف (7 حلول مختلفة) Reverse Values In Row

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

أقدم لكم 7 طرق لعكس القيم في صف ، والحصول على نتائج القيم معكوسة في صف آخر.

بفرض أن لديك نطاق من القيم وليكن B5:H8 ، والمطلوب عكس قيم النطاق في صف آخر ؛ بمعنى لو كانت القيم هي 11 - 23 - 43 - 56 - 87 - 54 - 8 ، فالمطلوب في صف النتائج أن تكون القيم بالشكل التالي : 8 - 54 - 87 - 56 - 43 - 23 - 11


في الملف المرفق يوجد 7 طرق لأداء المطلوب (أربعة طرق بالمعادلات وثلاثة طرق بالأكواد)

إعداد / ياسر خليل أبو البراء

الاثنين، 9 مايو 2016

إغلاق وحماية الخلايا في نطاق محدد بعد الإدخال Locking Cells After Input

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

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

بفرض أن لديك العمود F وتريد أن تقوم بحماية الخلايا بعد عملية الإدخال للأرقام فقط ، أي أنك تريد السماح بإدخال أي نوع من أنواع البيانات بدون إغلاق الخلايا ، أما إذا كان البيان المدخل رقم تتم عملية إغلاق وحماية الخلية بعد الإدخال.

خطوات العمل : قم بتحديد كافة خلايا ورقة العمل من المنطقة المشتركة بين الصفوف والأعمدة
كليك يمين على الخلايا ثم اختر الأمر تنسيق خلايا Format Cells واذهب للتبويب Protection وأزل علامة الصح أو أي علامة داخل مربع الخيار Locked ، وهذا لفك حماية كافة خلايا ورقة العمل قبل وضع الكود.
وأخيراً قم بوضع الكود التالي في حدث ورقة العمل ، كليك يمين على اسم ورقة العمل ثم اختر View Code ثم الصق الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    Dim Cel As Object

    Set Rng = Range("F" & Target.Row & ":F" & Target.Row)
    
    For Each Cel In Rng
        If Cel.Value = vbNullString Or Not IsNumeric(Cel) Then Exit Sub
    Next Cel
    
    Sheets("Sheet1").Unprotect
        Rng.Locked = True
    Sheets("Sheet1").Protect
End Sub

إعداد / ياسر خليل أبو البراء

الأحد، 8 مايو 2016

إلغاء زر إغلاق الفورم Disable Close Button UserForm

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

أقدم لكم كود يوضع في حدث الفورم ، ويقوم الكود بإلغاء زر الإغلاق Close Button ، وإجبار المستخدم على استخدام زر إغلاق مصمم على الفورم

يوضع الكود التالي في موديول عادي ، لإظهار الفورم
Sub ShowForm()
    UserForm1.Show
End Sub

يوضع الكود التالي في حدث الفورم (كليك يمين على اسم الفورم في نافذة المشروع ثم View Code)
Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        Cancel = True
        MsgBox "Close Button Has Been Disabled", vbCritical
    End If
End Sub

إعداد / ياسر خليل أبو البراء

السبت، 7 مايو 2016

إدراج التاريخ أتوماتيكياً بمجرد إدخال بيان Insert Date Automatically Worksheet Change

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

أقدم لكم كود يوضع في حدث ورقة العمل ويقوم الكود بإدراج التاريخ بشكل تلقائي.


بفرض أن لديك النطاق A2:A20 ، والمطلوب أنه عند أي إدخال جديد في النطاق يتم إدراج التاريخ في الخلية المقابلة لها في العمود الثالث ، وهذا ما يقوم به الكود ، والكود فيه مرونة في التعامل ، أي أنه يمكن التعامل مع خلية واحدة فقط أو مجموعة خلايا ، ويتم مسح التاريخ بمجرد مسح الخلية أو الخلايا ، كما أنه يتأثر بعملية النسخ ، أي إذا قمت بنسخ خلية أو أكثر من أي مكان ووضعها في العمود الأول ، يتم إدراج التاريخ في العمود الثالث.

وأخيراً إليكم الكود ، ويوضع الكود في حدث ورقة العمل

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Target, Range("A2:A20")) Is Nothing Then
        VBA.Calendar = vbCalGreg

        If Len(Target.Cells(1).Value2) <> 0 Then
            Cells(Target.Row, 3).Resize(Target.Rows.Count).Value = Date
        Else
            Cells(Target.Row, 3).Resize(Target.Rows.Count).Value = vbNullString
        End If
    End If
End Sub

إعداد / ياسر خليل أبو البراء

الأربعاء، 4 مايو 2016

تشغيل ماكرو في وقت محدد Run Macro At Specific Time

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

أحياناً يطلب البعض طريقة تشغيل ماكرو في وقت محدد ، لذا آثرت أن أضع الطريقة بأسلوب بسيط جداً لكي تتضح الفكرة.

بفرض أن لدينا ماكرو أو إجراء فرعي باسم Test ، ويحتوي على كود نريد تنفيذه في وقت محدد وليكن في تمام الساعة الثالثة مساءاً أي الساعة 15:00 ..

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

Sub Test()
    MsgBox "This Is Test", 64
    'Your Code
End Sub

ونضع الكود التالي في حدث المصنف ، ليتم تنفيذ الكود في الوقت الذي نحدده من خلال الكود بهذا الشكل

Private Sub Workbook_Open()
    Application.OnTime TimeValue("15:00:00"), "Test"
End Sub

إعداد / ياسر خليل أبو البراء

الثلاثاء، 3 مايو 2016

انشطار أوراق العمل إلى مصنفات منفصلة Split Worksheets Into Multiple Workbooks

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

أقدم لكم كود يقوم بإنشاء مصنف منفصل لكل ورقة عمل في نفس مسار المصنف الحالي

بفرض أن لديك أربعة أوراق عمل ( الأول Main - الثاني Data - الثالث Search - الرابع Result) ، وبعض أوراق العمل يحتوي على معادلات ، والبعض يحتوي على أكواد في حدث المصنف
والمطلوب تصدير كل ورقة عمل إلى مصنف جديد وتحويل المعادلات إلى قيم ، والتخلص من الأكواد الموجودة في حدث ورقة العمل

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

وأخيراً إليكم الكود الذي يؤدي هذه المهمة

Sub Split_Workbook()
    Dim xPath As String
    Dim Sh As Worksheet
    Dim strName As String
    
    xPath = Application.ActiveWorkbook.Path

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
        For Each Sh In ThisWorkbook.Worksheets
            Sh.Copy
            ActiveWorkbook.ActiveSheet.UsedRange.Value = ActiveWorkbook.ActiveSheet.UsedRange.Value
            
            strName = Sh.CodeName
            With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
                .DeleteLines 1, .CountOfLines
            End With
            
            Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & Sh.Name & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.ActiveWorkbook.Close False
        Next Sh
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

تحميل الملف من هنا

إعداد / ياسر خليل أبو البراء

الاثنين، 2 مايو 2016

حذف ورقة عمل وإلغاء رسائل التحذير Delete Sheet & Disable Alerts

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

أقدم لكم درس بسيط حول كيفية حذف ورقة عمل بالكود وإلغاء الرسائل التحذيرية.

لربما يسأل البعض ما هذا التدني في المستوى في تقديم محتوى بسيط وسهل؟ والبعض قد يلجأ إلى تسجيل الماكرو ويحذف ورقة العمل ليحصل على الماكرو المطلوب بالشكل التالي ، ويظن أن الموضوع قد انتهى لهذا الحد.
Sub Macro1()
'
' Macro1 Macro
'

'
    Sheets("Data").Select
    ActiveWindow.SelectedSheets.Delete
End Sub
في الحقيقة أحببت أن أتناول معكم الموضوع بشكل علمي وعملي وممنهج ، لنرتقي بطريقة التفكير التي نفكر بها إلى مستوى أعلى
إذا أردنا أن نقوم بالبرمجة فعلينا التفكير في كل الاحتمالات الممكنة حتى يكون الكود شامل ولا يحتوي على ثغرات .. فلنبدأ بضرب مثال ، ونفرض الفروض الممكنة ونرى كيف نعالج هذه الاحتمالات

بفرض أن لدينا ثلاثة أوراق عمل Sheet1 و Data و Report ، والمطلوب حذف ورقة العمل المسماة Data

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

أي أن الإكسيل يقوم بحذف ورقة العمل بشكل نهائي ، هل تود الاستمرار؟ - والتراجع باستخدام Ctrl + Z بعد التأكيد على الحذف لن يجدي ، وعليك إذا كنت تريد التراجع أن تقوم بإغلاق المصنف بدون حفظ وإعادة فتحه من جديد
ما يهمنا في هذه النقطة أننا نريد ألا تظهر رسالة التحذير أثناء تشغيل الكود ، والأمر ببساطة أننا نقوم بإلغاء خاصية رسائل التحذير DisplayAlerts بوضع القيمة False لها في بداية تنفيذ الأمر ، ولا ننسى أن نقوم بإعادة الخاصية مرة أخرى بوضع القيمة True لها بعد انتهاء عمل الكود

النقطة الثانية نفترض أن ورقة العمل المطلوب حذفها غير موجود ، وقمت بتنفيذ الكود ، ستظهر لك رسالة خطأ ، قم بتجربة الكود التالي
Sub Delete_Sheet()
    Dim strSh As String
    strSh = "Data"

    Application.DisplayAlerts = False
        Sheets(strSh).Delete
        MsgBox "Sheet Deleted ...", 64
    Application.DisplayAlerts = True
End Sub
نفذ الكود لمرة ستحذف ورقة العمل Data ، ثم نفذ الكود مرة أخرى ستظهر لك رسالة خطأ بهذا الشكل
ولعلاج الخطأ يجب أن نقوم بفحص ما إذا كانت ورقة العمل موجودة أم لا ، فإذا كانت موجودة نقوم بحذفها ، وإذا كانت ورقة العمل غير موجودة يظهر رسالة لنا تفيد بأنها غير موجودة.
هنا نستخدم دالة Evaluate ، وهذه الدالة تفيد في الحصول على قيمة من تنفيذ معادلة أو دالة من الدوال المبنية داخل الإكسيل ، على سبيل المثال إذا كان لدينا أرقام في الخلايا A1:A3 ، وفي الخلية A4 أردنا جمع الخلايا نقوم باستخدام دالة الجمع Sum يليها النطاق A1:A3 بين قوسين ، يمكن استخدام الدالة Evaluate للحصول على القيمة بتنفيذ المعادلة بها بالشكل التالي
Sub Test_Evaluate()
    MsgBox Evaluate("=SUM(A1:A3)")
End Sub
نلاحظ أننا وضعنا المعادلة بين أقواس ( ) وبين أقواس تنصيص ، ثم بينهما وضعت المعادلة ، وعند تنفيذ الكود نحصل على الناتج أو القيمة.
نرجع لما كنا بصدده ألا وهو أننا نريد فحص ورقة العمل ، وببساطة نستخدم الدالة ISREF والتي ترجع القيمة True إذا كانت ورقة العمل موجودة ، ولذا يمكن تطوير الكود بهذا الشكل لتفادي الخطأ في حالة عدم وجود ورقة العمل
Sub Delete_Sheet()
    Dim strSh As String
    strSh = "Data"

    Application.DisplayAlerts = False
        If Evaluate("=ISREF('" & strSh & "'!A1)") Then
            Sheets(strSh).Delete
            MsgBox "Sheet Deleted ...", 64
        Else
            MsgBox "The Sheet Does Not Exist", vbExclamation
        End If
    Application.DisplayAlerts = True
End Sub
النقطة الثالثة والأخيرة وهي احتمال أن تكون ورقة العمل المطلوب حذفها هي ورقة العمل الوحيدة بالمصنف ، بفرض أننا قمنا بحذف ورقتي العمل Sheet1 و Report وأردنا أن نقوم بحذف ورقة العمل الوحيدة Data والتي لا يوجد غيرها
رغم أننا بالكود وضعنا إلغاء رسائل التحذير إلا أن الأمر لا ينتهي ، إذ أن منطق الإكسيل يخبرنا أنه يجب أن يحتوي المصنف على ورقة عمل واحدة على الأقل ، ولعلاج تلك المشلكة يمكننا إضافة سطر قبل تنفيذ الكود يقوم باختبار عدد أوراق العمل الموجودة ، فإذا كان عدد أوراق العمل = 1 ، نظهر رسالة تفيد بذلك ونستخدم جملة Exit Sub للخروج من الإجراء الفرعي

وها هو الكود بالشكل النهائي له بعد محاولة تفادي كل الاحتمالات الممكنة
Sub Delete_Sheet()
    Dim strSh As String
    strSh = "Data"

    Application.DisplayAlerts = False
        If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub
        If Evaluate("=ISREF('" & strSh & "'!A1)") Then
            Sheets(strSh).Delete
            MsgBox "Sheet Deleted ...", 64
        Else
            MsgBox "The Sheet Does Not Exist", vbExclamation
        End If
    Application.DisplayAlerts = True
End Sub

إعداد / ياسر خليل أبو البراء

الأحد، 1 مايو 2016

دالة الترتيب حسب درجات الطلاب Ordinal Number UDF Function

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

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

بفرض أن لديك مجموعة طلاب ولهم درجات في العمود الثالث في النطاق C2:C11 ، والمطلوب ترتيب الطلاب حسب الدرجات.

أولاً نقوم بتسمية نطاق الدرجات لتسهيل التعديل في المعادلة حسب ملفك ، نحدد النطاق C2:C11 ونضع مؤشر الماوس في صندوق الاسم على يسار شريط المعادلات ونكتب اسم للنطاق وليكن Marks ، حيث سنستخدم هذا الاسم في المعادلة.

قم بوضع الدالة المعرفة التالية في موديول عادي (للدخول لمحرر الأكواد اضغط Alt + F11 ، ومن قائمة Insert اختر الأمر Module ثم الصق الدالة المعرفة التالية) 

Function OrdinalNum(ByVal Num As Variant, Optional ByVal Sex As Byte = 0) As String
    Const Male = 0
    Const Female = 1
    Dim Sings(1 To 11) As String
    Dim Tens(2 To 10) As String
    Dim Fem As String

    On Error Resume Next

    OrdinalNum = Num
    Num = CDbl(Num)
    If Num < 1 Or Num > 100 Or Num <> CLng(Num) Then
        Exit Function
    End If

    Sings(1) = "الأول"
    Sings(2) = "الثاني"
    Sings(3) = "الثالث"
    Sings(4) = "الرابع"
    Sings(5) = "الخامس"
    Sings(6) = "السادس"
    Sings(7) = "السابع"
    Sings(8) = "الثامن"
    Sings(9) = "التاسع"
    Sings(10) = "العاشر"
    Sings(11) = "الحادي"

    Tens(2) = "العشرون"
    Tens(3) = "الثلاثون"
    Tens(4) = "الأربعون"
    Tens(5) = "الخمسون"
    Tens(6) = "الستون"
    Tens(7) = "السبعون"
    Tens(8) = "الثمانون"
    Tens(9) = "التسعون"
    Tens(10) = "المائة"

    If Sex > Female Then Sex = Male
    Fem = IIf(Sex = 0, "", "ة")

    Select Case Num
    Case 1: OrdinalNum = Sings(Num) & IIf(Sex = Male, "", "ى")
    Case 2 To 10: OrdinalNum = Sings(Num) & Fem
    Case 11: OrdinalNum = Sings(Num) & Fem & " عشر" & Fem
    Case 12 To 19: OrdinalNum = Sings(Num Mod 10) & Fem & " عشر" & Fem
    Case Else
        Select Case Num Mod 10
        Case 0: OrdinalNum = Tens(CLng(Num / 10))
        Case 1: OrdinalNum = Sings(11) & Fem & " و" & Tens(Fix(Num / 10))
        Case Else: OrdinalNum = Sings(Num Mod 10) & Fem & " و" & Tens(Fix(Num / 10))
        End Select
    End Select
End Function

الآن ننتقل لآخر جزئية وهي أننا سنقوم بوضع معادلة في الخلية D2 بهذا الشكل

=OrdinalNum(RANK(C2,Marks))

ثم نضع معادلة أخرى في الخلية D3 بهذا الشكل (وبعدها نسحب هذه المعادلة لنهاية النطاق أي إلى الخلية D11)

=IF(C3=C2,OrdinalNum(RANK(C3,Marks))&" مكرر",OrdinalNum(RANK(C3,Marks)))

إعداد / ياسر خليل أبو البراء

ثلاثة طرق لتحديد أوراق العمل بالكود Select Sheets Methods

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

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

وإليكم فيديو يوضح كيفية استخدام الطرق الثلاثة لتحديد أوراق العمل

وها هو الكود المستخدم للثلاثة طرق

Sub SelectSheetByItsTabName()
    Sheets("Data").Select
End Sub

Sub SelectSheetByItsIndexNumber()
    Sheets(4).Select
End Sub

Sub SelectSheetByItsCodeName()
    Sheet4.Select
End Sub

إعداد / ياسر خليل أبو البراء

استخراج القيم الفريدة أي الغير مكررة في نطاق Unique List By Collection

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

كثيراً ما نحتاج لهذا الأمر ألا وهو استخراج القيم الفريدة أي الغير مكررة من نطاق لاستخدامها في نطاق آخر أو ربما نريدها لتعبئة كومبوبوكس أو خلافه.

بفرض أن لديك مجموعة من الأسماء فيها أسماء مكررة في النطاق A2:A15 ، والمطلوب استخراج الأسماء الغير مكررة ووضع النتائج في العمود الثالث.


يمكن استخراج القيم المكررة باستخدام معادلة صفيف (أي يجب الضغط على
Ctrl + Shift + Enter بعد إدخال المعادلة)
نقوم بوضع المعادلة في الخلية H2 على سبيل المثال بهذا الشكل

=IFERROR(IF(A2<>"",INDEX($A$2:$A$15,MATCH(0,COUNTIF($H$1:H1,$A$2:$A$15),0)),""),"")
 
إليكم الكود المستخدم لتنفيذ المهمة ، ويوضع الكود في موديول عادي

Sub Unique_List()
    'تعريف المتغيرات
    Dim Rng As Range
    Dim Cel As Range
    Dim Coll As New Collection
    Dim I As Integer

    'تعيين النطاق المراد استخراج القيم الفريدة منه
    Set Rng = Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)

    'سطر لتجنب حدوث خطأ لأنه عند إضافة عنصر موجود من قبل يحدث خطأ
    On Error Resume Next

    'حلقة تكرارية لكل خلية من خلايا النطاق
    For Each Cel In Rng
        'إضافة العنصر أو قيمة الخلية ويمثل الجزء بعد الفاصلة مفتاح فريد
        'لتحويل قيمة الخلية لقيمة نصية في حالة التعامل مع الأرقام [Cstr] وتم استخدام الدالة
        Coll.Add Cel.Value, CStr(Cel.Value)
    Next Cel

    'وضع قيم الكائن الذي استخدم في تخزين القيم الفريدة في العمود الثالث
    For I = 1 To Coll.Count
        Sheet1.Cells(I + 1, 3).Value = Coll(I)
    Next I
End Sub

إعداد / ياسر خليل أبو البراء

دالة التلوين في محرر الأكواد RGB Tutorial

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

أقدم لكم معلومة بسيطة حول الدالة RGB والتي تستخدم في الـ VBA بغرض التلوين ، والدالة لها ثلاثة بارامترات أي ثلاثة مدخلات : الأول هو رقم بين 0 و 255 يمثل اللون الأحمر ، والثاني رقم بين 0 و 255 يمثل اللون الأخضر ، والثالث رقم بين 0 و 255 يمثل اللون الأزرق.
حيث R اختصار لكلمة Red ، و G اختصار لكلمة Green ، و B اختصار لكلمة Blue.

على سبيل المثال إذا أردنا تلوين خلفية خلية باللون الأصفر ، وليكن الخلية A1 ، فيكون سطر الكود بهذا الشكل

Sub Test()
    Range("A1").Interior.Color = RGB(250, 250, 0)
End Sub

حيث أن كلمة Interior تعني التعامل مع الخلفية للنطاق أو الخلية ، وكلمة Color للتعامل مع اللون ، أي أننا نخبر الإكسيل بأننا نريد لون الخلفية للخلية A1 يساوي قيم الدالة RGB والتي تساوي 250 و 250 وصفر


وأخيراً إليكم ملف مرفق فيه أرقام عشوائية بين 0 و 255 في الأعمدة الثلاثة الأولى ، وتظهر الألوان في العمود الرابع ، ويوضع الكود في حدث ورقة العمل .. لتجريب الكود يمكنك الضغط على مفتاح F9 من لوحة المفاتيح ولاحظ تغير الألوان في العمود الرابع

Private Sub Worksheet_Calculate()
    Dim Cel As Range
    For Each Cel In Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
        Cel.Interior.Color = RGB(Cel.Offset(, -3), Cel.Offset(, -2), Cel.Offset(, -1))
    Next Cel
End Sub

إعداد / ياسر خليل أبو البراء