فصل الناجحين عن الراسبين باستخدام الحلقات التكرارية Transfer Nageh Raseb

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

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

ولديك ثلاثة أوراق عمل : ورقة عمل باسم "ناجح" ، وورقة عمل باسم "دور ثان" ، وورقة عمل باسم "راسب"

والمطلوب ترحيل أو فصل بيانات كل قسم إلى ورقة العمل المناسبة.

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

Sub Tarhil_Ragab()
    'تعريف المتغيرات
    Dim Sh As Worksheet
    Dim strSh As String
    Dim I As Long
    Dim AA As Long

    'سطر لإيقاف تحديث الشاشة
    Application.ScreenUpdating = False
    
        'مسح محتويات النطاق في ورقة العمل ناجح
        Sheets("ناجح").Range("A12:X1000").ClearContents
    
        'مسح محتويات النطاق في ورقة العمل دور ثان
        Sheets("دور ثان").Range("A12:X1000").ClearContents
    
        'مسح محتويات النطاق في ورقة العمل راسب
        Sheets("راسب").Range("A12:X1000").ClearContents
    
        'بدء التعامل مع ورقة العمل الأولى التي تعتبر الورقة الرئيسية
        With Sheet1
        
            '[Y] حلقة تكرارية بدايةً من الصف الـ 12 وحتى آخر صف به بيانات بالاعتماد على العمود
            For I = 12 To .Cells(10000, "Y").End(xlUp).Row
    
                '[Y] تعيين قيمة المتغير ليساوي قيمة الخلية في الصف المحدد في العمود
                'ففي أول حلقة تكرارية سيكون الصف هو رقم 12 [I] المقصود بالصف المحدد الصف الذي يحمل قيمة المتغير
                'وفي الحلقة التالية سيكون الصف رقم 13 وهكذا مع كل حلقة تكرارية يتغير الصف
                strSh = .Cells(I, "Y").Value
    
                'تعيين المتغير ليساوي آخر صف في الورقة التي سيتم الترحيل إليها
                'أو يمكنك القول معرفة رقم صف أول صف فارغ
                AA = Sheets(strSh).Cells(10000, 2).End(xlUp).Row + 1
    
                'إذا كان المتغير أقل من 12 الذي من المفترض أنه صف البداية لعمليات الترحيل فإنه يتم تعيين المتغير ليساوي 12
                If AA < 12 Then AA = 12
    
                'في حالة حدوث خطأ يتم تجنبه بهذا السطر
                On Error Resume Next
    
                'نسخ النطاق في الصف المحدد من العمود الثاني إلى العمود الرابع والعشرون
                .Range(.Cells(I, "B"), .Cells(I, "X")).Copy
    
                'لصق النطاق المنسوخ إلى ورقة العمل المناسبة واللصق يكون لصق قيم فقط
                Sheets(strSh).Range("B" & AA).PasteSpecial xlPasteValues
    
                'إلغاء خاصية النسخ واللصق
                Application.CutCopyMode = False
    
                'هذا السطر يقوم بترقيم الصف الذي تم ترحيله في الورقة الهدف
                'حيث يعتمد على إنقاص 11 من رقم الصف الحالي
                'فإذا كان الصف الحالي هو رقم 12 ألا وهو رقم البداية فإن الرقم
                'المسلسل سيكون 12 - 11 أي سيكون الرقم المسلسل 1
                Sheets(strSh).Cells(AA, "A").Value = Sheets(strSh).Cells(AA, "A").Row - 11
    
                'الانتقال للصف التالي في الحلقة التكرارية
            Next I
    
            'حلقة تكرارية لكل أوراق العمل لتحديد الخلية الأولى في ورقةالعمل
            For Each Sh In ThisWorkbook.Worksheets
                Application.Goto Sh.Range("A1")
            Next Sh
    
            'تنشيط ورقة العمل الأولى
            .Activate
    
        'انتهاء التعامل مع ورقة العمل الأولى
        End With
        
    'سطر لإعادة تفعيل اهتزاز الشاشة
    Application.ScreenUpdating = True

    'إظهار رسالة تفيد بانتهاء عمل الكود
    MsgBox "تم الفصل بنجاح", 64
End Sub

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

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

تحديد ملف باستخدام مستعرض الملفات Select Single File By File Dialog

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

أقدم لكم كود يقوم بتحديد أي ملف من خلال نافذة مستعرض الملفات File Dialog.

يوضع الكود في موديول عادي ، وإليكم الكود مع شرح تفصيلي لأسطر الكود للاستفادة منه

Sub Open_File_Dialog()
    Dim Wb As Workbook
    Dim I As Integer
    Dim strPath As String

    'يمكن تحديد أكثر من ملف [True] السماح للمستخدم باختيار ملف واحد وبتغيير القيمة إلى
    Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False

    'إظهار نافذة مستعرض الملفات
    I = Application.FileDialog(msoFileDialogOpen).Show

    'إذا تم تحديد ملف فإن المتغير لن يساوي صفر ويتم تنفيذ التالي
    If I <> 0 Then
        'تعيين قيمة المتغير ليساوي مسار الملف الذي قمت بتحديده
        strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)

        'إظهار مسار الملف في رسالة
        MsgBox strPath

        'فتح المصنف بعد معرفة مساره
        Set Wb = Workbooks.Open(strPath)

        'إظهار قيمة الخلية الأولى في ورقة العمل الأولى في المصنف في رسالة
        MsgBox Wb.Sheets("Sheet1").Range("A1").Value

        '[True] إغلاق المصنف بدون حفظ وإذا أردت الحفظ قم بتغيير القيمة إلى
        Wb.Close False
        'أما إذا لم يتم تحديد ملف فإن المتغير يساوي صفر ويتم تنفيذ التالي
    Else
        'إظهار رسالة تفيد بأن المستخدم قد قام بإلغاء تحديد الملف
        MsgBox "Cancelled By The User", 64
    End If
End Sub

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

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

تصدير كل أوراق العمل إلى ملفات بي دي إف منفصلة Export Each Sheet To PDF

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

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

الرابط من هنا

استكمالاً للموضوع أقدم لكم كود يقوم بتصدير أوراق العمل بالمصنف الحالي إلى ملفات PDF ، والفرق أن عملية التصدير ستكون لكل ورقة عمل ملف PDF خاص ورقة العمل ، أي يتم التصدير بشكل منفصل لكل ورقة عمل.

وإليكم الكود الذي يؤدي المهمة ، ويوضع الكود في موديول عادي

Sub Create_PDF_Files_For_Each_Sheet()
    Dim Ws As Worksheet
    Dim Fname As String
    
    Application.ScreenUpdating = False
        For Each Ws In ActiveWorkbook.Worksheets
            On Error Resume Next
            Fname = ThisWorkbook.Path & "\Exported " & Ws.Name
            Ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fname, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
        Next Ws
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

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

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

إخفاء المعادلات عن طريق حماية ورقة العمل Hide Formulas By Sheet Protection

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

أقدم لكم طريقة بسيطة لإخفاء المعادلات في ورقة العمل في خطوات منسقة :
1- قم بتحديد كافة خلايا ورقة العمل بالنقر على هذه المنطقة

2- كليك يمين على الخلايا ثم اختر الأمر تنسيق خلايا Format Cells ثم انتقل للتبويب Protection ، وأزل علامة الصح بجانب الخيار Locked أي إذا كانت مظللة قم بإزالة التظليل ثم إزالة علامة الصح ، بحيث يكون مربع الاختيار فارغ

3- حدد الخلايا المراد عمل حماية لها ، والتي تحتوي على المعادلات المراد حمايتها ، ثم كليك يمين عليها واختر تنسيق خلايا Format Cells وانتقل للتبويب Protection وضع علامة صح بجانب الخيار Locked

4- قم بحماية ورقة العمل من خلال التبويب Review ثم انقر الأمر Protect Sheet ثم OK (يمكنك وضع كلمة سر لورقة العمل)

5- قم بوضع الكود التالي في حدث المصنف لتتم الحماية عن طريق عدم تمكين المستخدم من اختيار أو تحديد الخلية المحمية

Private Sub Workbook_Open()
    Sheets("Sheet1").EnableSelection = xlUnlockedCells
End Sub

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

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

تحديد مدى التنقل أو التصفح في ورقة العمل Limit Scroll Area

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

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

على سبيل المثال لو لديك النطاق A1:F10 وتريد تحديد التنقل بين الخلايا في هذا النطاق فقط دون غيره ، كيف يمكن عمل ذلك؟

الطريقة الأولى بدون أكواد :

الذهاب إلى محرر الأكواد عن طريق الضغط على Alt + F11 ثم من نافذة المشروع Project Window تنقر نقر مزدوج (دبل كليك) على ورقة العمل المطلوب تحديد نطاق التنقل بها ، وليكن مثلاً Sheet1

الآن من نافذة الخصائص Properties Window ابحث عن الخاصية Scroll Area وفي الحقل المجاور اكتب النطاق المطلوب وهو A1:F10 (أو كما ترغب) ثم اضغط إنتر

الطريقة الثانية بالأكواد :

قم بوضع الكود التالي في حدث المصنف ليقوم بتحديد نطاق التنقل بمجرد فتح المصنف

Private Sub Workbook_Open()
    Sheets("Sheet1").ScrollArea = "A1:F10"
End Sub

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

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

إخفاء وإظهار النطاقات المعرفة Hide Show Defined Ranges

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

أقدم لكم كودين أحدهما يقوم بإخفاء النطاقات المعرفة (أو النطاقات المسماة) Defined Ranges ، والآخر يقوم بإظهارها.

بفرض أن لديك بعض النطاقات المسماة في المصنف ، على سبيل المثال النطاق A1:C10 تم تسمية النطاق باسم MyData (وتتم التسمية بتحديد النطاق ثم وضع مؤشر الماوس في صندوق الاسم على يسار شريط المعادلات ثم كتابة اسم للنطاق ثم الضغط على مفتاح الإدخال إنتر)

ولديك أيضاً النطاق D11:G14 باسم MyRange 

 يمكن الإطلاع على النطاقات المسماة من خلال التبويب Formulas ثم Name Manager لتظهر لك نافذة تحتوي على تفاصيل النطاقات المسماة بهذا الشكل

المطلوب إخفاء تلك النطاقات وإظهارها ، وهذا ما أقدمه لكم من خلال هذين الكودين

Sub HideAllNames()
    Dim objName As Excel.Name
    If Not Application.ActiveWorkbook Is Nothing Then
        For Each objName In Application.ActiveWorkbook.Names
            objName.Visible = False
        Next objName
    End If
End Sub

Sub UnhideAllNames()
    Dim objName As Excel.Name
    If Not Application.ActiveWorkbook Is Nothing Then
        For Each objName In Application.ActiveWorkbook.Names
            objName.Visible = True
        Next objName
    End If
End Sub

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

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

إلغاء زر الإغلاق لتطبيق الإكسيل Disable Application Close Button

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

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

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

وها هو الكود المستخدم ، حيث يوضع الكود التالي في موديول عادي ، يتم تعيين الإجراء الفرعي المسمى CloseMe لزر الأمر

Public CloseMode As Boolean

Sub CloseMe()
    CloseMode = True
    ThisWorkbook.Save
    Application.Quit
End Sub

ويوضع الكود التالي في حدث المصنف

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not CloseMode Then
        Cancel = True
        MsgBox "Please Use The button To Close This File"
    End If
End Sub

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

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

استبدال مجموعة من القيم والنصوص في كل أوراق العمل Replace Values In All Worksheets

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

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

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

نقوم بالتعديل في الكود في المتغير fndList حيث يمثل مصفوفة القيم القديمة المراد استبدالها ، وتوضع القيم بين أقواس تنصيص ، ثم نعدل في المتغير المسمى rplcList حيث يمثل مصفوفة القيم الجديدة التي ستوضع مكان القيم القديمة ، وتوضع بين أقواس تنصيص ، فيقوم الكود بعملية البحث والاستبدال في كل أوراق العمل مرة واحدة.

وأخيراً إليكم الكود المستخدم ، ويوضع الكود في موديول عادي

Sub Replace_In_All_Worksheets()
    Dim Ws As Worksheet
    Dim fndList As Variant
    Dim rplcList As Variant
    Dim I As Long

    'Old List
    fndList = Array("Yaser", " - ", "helo", "ecxel")

    'New List
    rplcList = Array("Yasser", " | ", "Hello", "Excel")

    Application.ScreenUpdating = False
        For I = LBound(fndList) To UBound(fndList)
            For Each Ws In ActiveWorkbook.Worksheets
                Ws.Cells.Replace What:=fndList(I), Replacement:=rplcList(I), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            Next Ws
        Next I
    Application.ScreenUpdating = True
    
    MsgBox "Done...", 64
End Sub

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

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

إغلاق كل النوافذ المفتوحة في محرر الأكواد Close All Open VBE Windows

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

إليكم كود يقوم بإغلاق كافة النوافذ المفتوحة في محرر الأكواد ما عدا نافذة المشروع ونافذة الخصائص.

قم بإظهار بعض النوافذ من قائمة View لتجربة الكود ، ثم قم بتنفيذ الكود ليتم إغلاق كل النوافذ المفتوحة ما عدا نافذة المشروع Project Window ونافذة الخصائص Properties ، كما يمكن إخفاء النافذتين بالتعديل في الكود.

 

الكود المستخدم يوضع في موديول وينفذ داخل محرر الأكواد من قائمة Run ثم الأمر Run Sub/Userform أو يمكن وضع مؤشر الماوس داخل الموديول ثم اضغط F5 من لوحة المفاتيح

Sub Close_All_Open_VBE_Windows()
    Dim CodeWindow As Object
    ThisWorkbook.VBProject.VBE.ActiveWindow.Visible = True
    
    For Each CodeWindow In ThisWorkbook.VBProject.VBE.Windows
        If Not CodeWindow.Caption = ThisWorkbook.VBProject.VBE.ActiveWindow.Caption Then
            If Not CodeWindow.Caption = "Project - VBAProject" And Not Mid(CodeWindow.Caption, 1, 10) = "Properties" Then
                CodeWindow.Visible = False
            End If
        End If
    Next CodeWindow

    ThisWorkbook.VBProject.VBE.ActiveWindow.Visible = False
End Sub

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

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

التصفية التلقائية ونسخ الخلايا الظاهرة Autofilter & Copy Visible Cells

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

إليكم كود يقوم بعملية التصفية التلقائية Autofilter لنطاق ثم يقوم بنسخ الخلايا الظاهرة لعمود محدد ووضعها في قائمة حسب التصفية.

بفرض أن لديك بيانات في الأعمدة الثلاثة الأولى بهذا الشكل

والمطلوب توزيع الأسماء في العمود الثاني حسب اللجان في العمود الثالث ، لتكون النتائج بهذا الشكل

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

يعتمد الكود على عمل حلقة تكرارية للنطاق G2:J2 حيث يحتوي النطاق على أسماء اللجان المطلوب عمل تصفية للأسماء على أساسها ، وبعد عملية التصفية يتم نسخ الخلايا الظاهرة في العمود الثاني (عمود الأسماء) ولصقها في العمود المناسب حسب اسم اللجنة.

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

Sub Autofilter_Copy_Visible_Cells()
    Dim Cel As Range

    Application.ScreenUpdating = False
        With ActiveSheet
            .Range("G3:J1000").ClearContents
    
            For Each Cel In .Range("G2:J2")
                .AutoFilterMode = False
                .Range("A1:C1").AutoFilter Field:=3, Criteria1:=Cel.Value
                .Range("B2:B" & .Cells(Rows.Count, 2).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
    
                .Cells(3, Cel.Column).PasteSpecial xlPasteValues
            Next Cel
            
            .AutoFilterMode = False
            Application.Goto .Range("A1")
        End With
        
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

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

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

فتح وإغلاق السي دي روم Open Close CD-ROM

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

أقدم لكم كود يقوم بفتح السي دي روم (مشغل الإسطوانات CD-ROM) وكود آخر يقوم بإغلاقه.

إليكم الكود ويوضع في موديول عادي ، ويعمل على كلا النظامين 32 بت و 64 بت

#If VBA7 Then
    Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As LongPtr) As Long
#Else
    Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
#End If

Public Sub OpenCDDriveDoor(ByVal State As Boolean)
    If State = True Then
        Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
    Else
        Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
    End If
End Sub

Sub OpenCD()
    OpenCDDriveDoor (True)
End Sub

Sub CloseCD()
    OpenCDDriveDoor (False)
End Sub

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

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

تعبئة قائمة منسدلة في الفورم من بيانات مفلترة Fill ComboBox With Unique From Filtered Range

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

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

بفرض أن لديك النطاق A2:A25 به بيانات وقد قمت بفلترة النطاق بعدة شروط وليكن الأرقام 1 و 4 و 8 و 7 ، والمطلوب تعبئة الكومبوبوكس بتلك القيم بدون تكرارها في القائمة المنسدلة ، لتصبح بهذا الشكل

قم بوضع أداة الكومبوبوكس على الفورم ، ثم ضع الكود التالي في حدث الفورم 

Private Sub UserForm_Initialize()
    Dim Cel As Range
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        
        For Each Cel In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants)
            .Item(Cel.Value) = 1
        Next Cel
        
        Me.ComboBox1.List = .Keys
    End With
    
    Me.ComboBox1.ListIndex = 0
End Sub

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

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

استخراج تاريخ الميلاد والنوع ومحافظة الميلاد من الرقم القومي Birth Date Gender Province UDF Function

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

أقدم لكم دالة معرفة User-Defined Function تقوم باستخراج تاريخ الميلاد والنوع ومحافظة الميلاد من الرقم القومي (لدولة مصر حيث الرقم القومي مكون من 14 رقم).

استخدام الدالة :

قم بوضع الدالة المعرفة في موديول عادي ثم انتقل لورقة العمل لكتابة المعادلات

بفرض أن الرقم القومي موجود في الخلية A2 ، قم بكتابة المعادلة التالية في الخلية B2 لاستخراج تاريخ الميلاد

=Kh_Date_Gender_Province(A2,1)

والمعادلة التالية لتحديد النوع (ذكر أو أنثى) ضعها في الخلية C2

=Kh_Date_Gender_Province(A2,2)

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

=Kh_Date_Gender_Province(A2,3)

وأخيراً إليكم الدالة المعرفة وتوضع كما ذكرنا في موديول عادي :

Function Kh_Date_Gender_Province(MyNumber As Variant, MyTest As Byte)
    Dim MyProvinces As Variant
    Dim R As Long
    Dim YY As String
    Dim TY As String * 1
    Dim D As String * 2, M As String * 2, Y As String * 2, X As String * 2, XX As String * 2
    
    MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية", "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة", "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط", "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح", "23/الفيوم", "88/خارج الجمهورية", "11/دمياط", "04/السويس", "03/بورسعيد", "34/شمال سيناء", "35/جنوب سيناء", "32/الوادي الجديد", "31/البحر الأحمر")
    
    D = Mid(MyNumber, 6, 2)
    M = Mid(MyNumber, 4, 2)
    Y = Mid(MyNumber, 2, 2)
    TY = Left(MyNumber, 1)
    
    Select Case TY
        Case "2": YY = "19" & Y
        Case "3": YY = "20" & Y
        Case Else
    End Select

    Kh_Date_Gender_Province = ""
    On Error GoTo 1
   
    If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Or Len(Trim(MyNumber)) = 0 _
    Or Val(M) < 1 Or Val(M) > 12 Or (Val(TY) <> 2 And Val(TY) <> 3) Or Month(DateSerial(YY, M, D)) <> Val(M) Then
            Kh_Date_Gender_Province = ""
            GoTo 1
    End If
    
    If MyTest = 1 Then
        If YY <> "" Then Kh_Date_Gender_Province = DateSerial(YY, M, D)
    ElseIf MyTest = 2 Then
        If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then YY = "ذكر" Else YY = "أنثى"
        Kh_Date_Gender_Province = YY
    ElseIf MyTest = 3 Then
        X = Mid(MyNumber, 8, 2)
        For R = LBound(MyProvinces) To UBound(MyProvinces)
            XX = MyProvinces(R)
            If X = XX Then
                Kh_Date_Gender_Province = Right(MyProvinces(R), Len(MyProvinces(R)) - 3)
                Exit For
            End If
        Next
    End If
1: End Function

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

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

مقارنة عمودين واستخراج القيم الفريدة منهما Compare Two Columns And Extract Unique Items

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

إليكم كود يقوم بمقارنة القيم في عمودين ثم استخراج القيم الفريدة من العمودين ثم ترتيب النتائج تصاعدياً.

بفرض أن لديك عمودين العمود الأول والعمود الرابع ، والمطلوب إجراء عملية مقارنة بينهما بحيث يتم استخراج القيم الفريدة من العمودين (أي القيم الغير مكررة) .....

أي يتم مقارنة العمود الأول بالعمود الرابع والأرقام الفريدة توضع في العمود الثاني ويتم ترتيبها تصاعدياً ، ثم مقارنة العمود الرابع بالعمود الأول والأرقام الفريدة توضع في العمود الثالث ويتم ترتيبها تصاعديا.

إليكم الكود الذي يؤدي الغرض ، ويوضع الكود في موديول عادي Standard Module :

Sub Uniques_In_Two_Lists()
    Dim Cel     As Range
    Dim Rng1    As Range
    Dim Rng2    As Range

    Set Rng1 = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    Set Rng2 = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)

    Application.ScreenUpdating = False
        Range("B2:C1000").ClearContents
        Range("A1").CurrentRegion.Offset(1).Interior.Color = xlNone
        
        For Each Cel In Rng1
            If WorksheetFunction.CountIf(Rng2, Cel) = 0 Then
                Cel.Interior.Color = rgbSilver
                Range("B" & Rows.Count).End(xlUp).Offset(1) = Cel
            End If
        Next Cel
    
        For Each Cel In Rng2
            If WorksheetFunction.CountIf(Rng1, Cel) = 0 Then
                Cel.Interior.Color = rgbOlive
                Range("C" & Rows.Count).End(xlUp).Offset(1) = Cel
            End If
        Next Cel
    
        Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Sort Key1:=Range("B2"), Order1:=xlAscending
        Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlAscending
    Application.ScreenUpdating = True
End Sub

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

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

حذف الصفوف بطريقة مخصصة Delete Rows In Specific Way

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

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

بفرض أن لديك ورقة عمل باسم Data وبها الخلية G7 تحتوي على رقم ، هذا الرقم هو عدد الصفوف المراد حذفها.

ولديك ورقة عمل أخرى باسم Sheet1 وتريد حذف الصفوف بدايةً من الصف العاشر وبامتداد خمسة صفوف كما هو مقرر من الخلية G7 في ورقة العمل Data ، أي أنك تريد حذف الصفوف من الصف 10 إلى الصف 14 ( 10 - 11 - 12 - 13 - 14)

الكود مكون من جزء رئيسي وجزء فرعي ، الجزء الرئيسي يشبه الدوال المعرفة وهو عبارة عن إجراء مخصص ، أي له بارامترات يعتمد عليها كما في الدوال المعرفة UDF ، والبارامترات في الإجراء المخصص بالشكل التالي :

البارامتر الأول هو اسم ورقة العمل ويوضع بين أقواس تنصيص .. فكما في المثال اسم ورقة العمل المطلوب حذف الصفوف منها هو Sheet1.

والبارامتر الثاني هو صف البداية المطلوب بداية الحذف منه ، وهو هنا في المثال المرفق رقم 10 ، حيث يمثل أول صف تريد الحذف على أساسه.

لاستخدام هذا الإجراء المخصص ، تقوم بإنشاء إجراء فرعي وتكتب فيه اسم الإجراء المخصص وقد أسميته DeleteRow ، يليه اسم ورقة العمل "Sheet1" بين أقواس تنصيص ثم رقم صف البداية وهو الرقم 10

وأخيراً إليكم الكود المستخدم ، ويوضع الكود في موديول عادي :

Sub TestRun()
    DeleteRow "Sheet1", 10
End Sub

Sub DeleteRow(sSheet As String, sRow As Long)
    Dim Ws As Worksheet
    Dim cnt As Long

    On Error Resume Next
        Set Ws = Sheets(sSheet)
    On Error GoTo 0

    If Ws Is Nothing Then
        MsgBox "Sheet " & sSheet & "  Doesn't Exist.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
        cnt = Sheets("Data").Range("G7").Value
        Ws.Rows(sRow & ":" & (sRow + cnt - 1)).Delete
    Application.ScreenUpdating = True
End Sub

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

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

نسخ صف محدد قبل كل الصفوف Copy Specific Row Before Each Row

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

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

بفرض أن لديك ورقة عمل بها جدول بهذا الشكل :

والمطلوب أن يتم نسخ النطاق A1:D1 ويتم لصقه في كل الصفوف ، ليصبح بهذا الشكل :

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

وإليكم الكود المستخدم لتحقيق المطلوب ، يوضع الكود في موديول عادي Standard Module :

Sub Copy_Specific_Row()
    Dim I As Long
    
    Application.ScreenUpdating = False
        For I = Cells(Rows.Count, 1).End(xlUp).Row - 1 To 3 Step -1
            Range("A1:D1").Copy
            Range(Cells(I, "A"), Cells(I, "D")).Insert Shift:=xlDown
        Next I
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

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

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