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

الأربعاء، 7 سبتمبر 2016

فلترة البيانات وتصدير كل بيان حسب الفلترة إلى مصنفات جديدة Filter And Export To New Workbooks

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

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

مثال ليتضح المقال : بفرض أن لديك قائمة عملاء ، وأسماء العملاء مكررين ، وتريد تصدير بيانات كل عميل إلى مصنف جديد أي بيانات كل عميل تكون في مصنف مستقل

كما تلاحظون في الصورة المطلوب تصدير بيانات العملاء (محمد علي ، وفريد خان ، ومنصور السعيد ، ومنور أمين) كل عميل إلى مصنف مستقل ، ولا يشترط ترتيب البيانات في العمود ... ضع البيانات بأي شكل تريده ، والكود سيعمل بشكل ممتاز ليؤدي المطلوب إن شاء الله

في الكود تقوم بتحديد رقم أول عمود وهو هنا في المثال 1 أي العمود A ، كما نقوم بتحديد رقم آخر عمود وهو هنا 4 أي العمود D
كما تقوم بتحديد العمود الذي ستقوم بفلترة البيانات فيه وهو هنا عمود العملاء ألا وهو رقم 1
كما تقوم بتحديد اسم ورقة العمل المطلوب العمل عليها ، وهي ورقة العمل Sheet1

وأخيراً إليكم الكود الذي يؤدي المهمة (تصدير بيانات من نفس القيمة لمصنفات جديدة ، حيث يتم تصدير البيانات في نفس مسار المصنف الحالي في مجلد اسمه Output)

Sub Export_Workbooks_Using_Filter()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    Dim a           As Variant
    Dim I           As Long
    Dim P           As Integer
    Dim cnt         As Integer
    Dim Dic         As Object
    Dim strDir      As String
    Dim Arr()       As Double
    Dim iFlag       As Boolean

    '=========================================================
    Const firstCol  As Long = 1             'First Column
    Const lastCol   As Long = 4             'Last Column
    Const colNo     As Long = 1             'Column To Filter
    Const sSheet    As String = "Sheet1"    'Sheet Name
    '=========================================================

    strDir = ThisWorkbook.Path & "\Output\"
    For P = firstCol To lastCol
        ReDim Preserve Arr(P - 1)
        Arr(P - 1) = Sheets(sSheet).Columns(P).ColumnWidth
    Next P
    iFlag = Sheets(sSheet).DisplayRightToLeft

    Call SpeedUp
        If Dir(strDir, vbDirectory) = "" Then MkDir strDir
    
        Sheets.Add before:=Sheets(1)
        Set Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMOde = 1
    
        With Sheets(sSheet).[A1].CurrentRegion
            .Columns(colNo).Value = Application.Trim(.Columns(colNo).Value)
            a = .Value
            .Parent.AutoFilterMode = False
    
            For I = 2 To UBound(a, 1)
                If Not Dic.exists(a(I, colNo)) And Not IsEmpty(a(I, colNo)) Then
                    Dic(a(I, colNo)) = Empty
                    .AutoFilter colNo, a(I, colNo)
                    .Copy Sheets(1).Cells(1)
                    Sheets(1).Copy
    
                    With ActiveWorkbook
                        With Sheets(1)
                            .Name = "Sheet1"
                            .DisplayRightToLeft = iFlag
                            .Cells(1).CurrentRegion.RowHeight = 19
                            For cnt = firstCol To lastCol
                                .Columns(cnt).ColumnWidth = Arr(cnt - 1)
                            Next cnt
                        End With
    
                        .SaveAs strDir & RemoveSpecial(CStr(a(I, colNo))) & ".xlsx"
                        .Close
                    End With
    
                    Sheets(1).Cells.Clear
                    .AutoFilter
                End If
            Next I
        End With
    
        Sheets(1).Delete
    Call SpeedDown

    MsgBox "Done...", 64
End Sub

Function RemoveSpecial(sInput As String) As String
    Dim sSpecialChars   As String
    Dim I               As Long

    sSpecialChars = "\/:*?""<>|"
    For I = 1 To Len(sSpecialChars)
        sInput = VBA.Trim(Replace$(sInput, Mid$(sSpecialChars, I, 1), " "))
    Next I

    RemoveSpecial = sInput
End Function

Function SpeedUp()
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
End Function

Function SpeedDown()
    With Application
        .Calculation = xlAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Function

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

الثلاثاء، 6 سبتمبر 2016

تقسيم أو شطر قائمة واحدة إلى قائمتين بالتساوي Split List In Two Lists Equally

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




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

بفرض أن لديك قائمة بأسماء التلاميذ وليكن عدد التلاميذ 23 وتريد تقسيم القائمة أي شطرها إلى نصفين .. في الشطر الأيمن 12 طالب وفي الأيسر 11 طالب (الكود مرن ويتعامل مع أي عدد من الأسماء أو البيانات)

ترى هل يمكن عمل ذلك بسهولة؟ >> نعم جرب الكود التالي لترى بنفسك

إليكم الكود ... يقوم الكود بتقسيم القائمة إلى شطرين بالبيانات الملحقة بها وتظهر النتائج في ورقة العمل الثانية Sheet2

Sub SplitList()
'Author  : YasserKhalil
'Release : 07 - 09 - 2016
'------------------------
    'تعريف المتغيرات
    Dim shSource As Worksheet, shTarget As Worksheet
    Dim rList As Range, rListA As Range, rListB As Range
    Dim hCount As Long, tCount As Long
    
    'عدد أعمدة النطاق المراد عمل إنشطار له
    Const colNum As Integer = 3
    
    'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف
    Set shSource = Sheets("Sheet1")
    Set shTarget = Sheets("Sheet2")
    
    'تعيين النطاق الذي يحتوي على القائمة المراد شطرها
    Set rList = shSource.Range("A6:A" & shSource.Cells(Rows.Count, "A").End(xlUp).Row)
    
    'تعيين بداية النطاق للشطر الأول من القائمة
    Set rListA = shTarget.Range("A4")
    
    'تعيين بداية النطاق للشطر الثاني من القائمة
    Set rListB = rListA.Offset(, colNum)
    
    'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر
    tCount = rList.Cells.Count
    
    'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2
    hCount = Application.RoundUp(tCount / 2, 0)

    'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني
    shTarget.Range("A3").CurrentRegion.Offset(1).ClearContents
    
    'وضع نتائج الشطر الأول
    rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    'وضع نتائج الشطر الثاني
    rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value
    
    MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64
End Sub

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

الثلاثاء، 16 أغسطس 2016

تظليل صف وعمود الخلية النشطة باستخدام التنسيق الشرطي Highlight ActiveCell's Row And Column Using Conditional Formatting

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

أقدم لكم طريقة لتظليل صف وعمود الخلية النشطة مما يسهل على المستخدم معرفة الخلية النشطة ، والطريقة لا تؤثر على الخلايا الملونة أو الخلايا التي بها تنسيق شرطي (أي أنها آمنة)

خطوات العمل :

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





المعادلة المستخدمة في التنسيق الشرطي بالشكل التالي

=AND(COLUMN()=COLUMN(INDIRECT($P$1)),ROW()<=ROW(INDIRECT($P$1)))

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

=AND(ROW()=ROW(INDIRECT($P$1)),COLUMN()<=COLUMN(INDIRECT($P$1)))

وأخيراً كليك يمين على اسم ورقة العمل ثم اختر الأمر View Code ثم ضع الكود التالي في حدث ورقة العمل

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.ScreenUpdating = False
        Range("P1").Value = Target.Address
    Application.ScreenUpdating = True
End Sub

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

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

السبت، 9 يوليو 2016

تضمين فيديو من على اليوتيوب لملف إكسيل Embed YouTube Video Into Excel File

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

أقدم لكم طريقة تضمين فيديو من على اليوتيوب لملف إكسيل وبدون أكواد ، وبطريقة سهلة ويسيرة إن شاء الله

خطوات العمل : 
قم بنسخ عنوان الفيديو المراد تضمينه وإدراجه داخل ملف الإكسيل ويكون العنوان بهذا الشكل على سبيل المثال

https://www.youtube.com/watch?v=4rz56EHfm3w

قم بحذف كلمة watch وعلامة الاستفهام التي تلي الكلمة ، وقم باستبدال علامة يساوي = بعلامة / ، ليصبح العنوان بهذا الشكل

https://www.youtube.com/v/4rz56EHfm3w

افتح ملف الإكسيل المراد إدراج فيديو اليوتيوب فيه ، ثم قم بالذهاب للتبويب Developer وانقر على Design Mode أي وضع التصميم ، ثم اختر More Controls ثم قم بإدراج Shockwave Flash Object


بعد رسم الأداة على ورقة العمل ، قم بعمل كليك يمين ثم اختر الأمر Properties

الصق العنوان الذي تم تعديله في الخاصية Movie في نافذة الخصائص Properties


وإليكم ملف مرفق مطبق فيه الخطوات التي تم سردها

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



الجمعة، 8 يوليو 2016

كود طباعة صفحات محددة Select Printer & Print Specific Sheets

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

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

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

سأترك لكم الصور لمعرفة كيفية التعامل مع الكود 




وإليكم الكود المستخدم لتنفيذ الفكرة

Sub PrintSelectedSheets()
    Dim I As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet
    Dim Cb As CheckBox
    Dim Numcop As Long
    Dim Cnt As Integer
    Dim X As String
    
    Application.Dialogs(xlDialogPrinterSetup).Show
    
    Application.ScreenUpdating = False
        If ActiveWorkbook.ProtectStructure Then
            MsgBox "المصنف محمي", vbCritical
            Exit Sub
        End If
    
        Set CurrentSheet = ActiveSheet
        X = CurrentSheet.Name
        Set PrintDlg = ActiveWorkbook.DialogSheets.Add
        SheetCount = 0
    
        TopPos = 40
        For I = 1 To ActiveWorkbook.Worksheets.Count
            Set CurrentSheet = ActiveWorkbook.Worksheets(I)
    
            If Application.CountA(CurrentSheet.Cells) <> 0 And CurrentSheet.Visible Then
                SheetCount = SheetCount + 1
                PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
                PrintDlg.CheckBoxes(SheetCount).Text = CurrentSheet.Name
                TopPos = TopPos + 13
            End If
        Next I
    
        PrintDlg.Buttons.Left = 240
    
        With PrintDlg.DialogFrame
            .Height = Application.Max(68, PrintDlg.DialogFrame.Top + TopPos - 34)
            .Width = 230
            .Caption = "اختر أوراق العمل المراد طباعتها"
        End With
    
        PrintDlg.Buttons("Button 2").BringToFront
        PrintDlg.Buttons("Button 3").BringToFront
    
        Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1)
        If Numcop = 0 Then
        ElseIf Len(Numcop) > 0 Then
        End If
    
        CurrentSheet.Activate
    Application.ScreenUpdating = True

    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            For Each Cb In PrintDlg.CheckBoxes
                If Cb.Value = xlOn Then
                    If Cnt = 0 Then
                        Worksheets(Cb.Caption).Select
                    Else
                        Worksheets(Cb.Caption).Select Replace:=False
                    End If
                    Cnt = Cnt + 1
                End If
            Next Cb
            ActiveWindow.SelectedSheets.PrintOut copies:=Numcop

        End If
    Else
        MsgBox "كل أوراق العمل فارغة", 64
    End If

    Application.DisplayAlerts = False
    PrintDlg.Delete

    Sheets(X).Select
End Sub


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

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

الخميس، 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

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