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

[allhgory]

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

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

بارك الله فيك أخي الفاضل على كلماتك الرقيقة .. يبدو أنك شاعر ..

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

 

Codes Library v1.9.3.rar

[أبو عبدالإله]

أسأل الله سبحانه وتعالى أن يكتب لك في كل حرف حسنة ويضاعفه أضعافا مضاعفة

 

فقط تسجيل إعجاب لهذا الإبداع   

[أبو محمد عباس]

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

الاستاذ الفاضل والمبدع والمتفاني في عمله دائما ابو البراء المحترم

جهود مميزة وكبيرة لاثراء المنتدى بالمعلومة الجديدة والمفيدة

فانتم ينبوع العطاء للمنتدى من الخير والعلم والمعرفة

مع باقي الاساتذة الكبار الذين قدموا ويقدموا الكثير الكثير 

لا لشيء الا لمرضاه الله سبحانه وتعالى وهو اسمى من كل شيء

جعل الله عملكم هذا وجميع اعمالكم في موازين حسناتكم

وفقكم الله وزادكم من فضله خيرا وعلما ومعرفة

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

تقبلوا وافر احترامي وتقديري

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

الأخ الفاضل التاج

بارك الله فيك على مرورك العطر

الأخ الحبيب أبو محمد عباس

كلماتك دائماً تعتبر محفزاً لنا على المزيد من العمل ، جزيت عنا خير الجزاء ، وبارك الله فيك

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

تقبلوا تحياتي

[ابو تراب]

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

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

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

 

ما شاء الله عليك استاذ ياسر حلول القائمة المنسدلة المتناقصة لقدمتها ممتازة و الحل بالكود اروع

 

فكرة استخدامك لـل Evaluate ذكية فعلا

 

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

 

مرفق ملف لتجريب

Option Explicit


Const Main_SHEET As String = "Main"
Const LISTS_SHEET As String = "Lists"


Sub CreateDecreasingValidationList(List As Range, ValidationList As Range)
Dim ListValues As String
Dim FirstCell As String
Dim ValidationAddress As String
' احصل على عنوان الخلية الاولى في القائمة
FirstCell = Replace(List(1, 1).Address, "$", "")
' احصل على المسار الكلي لعنوان للشيت الرئيسية
ValidationAddress = "'" & ValidationList.Worksheet.Name & "'!" & ValidationList.Address


Application.ScreenUpdating = False
' استخدم العمود التالي لعمود القائمة لاجراء الاختبار
With List.Offset(, 1)
' حدث معادلة مدى البحث
    .Formula = "=IF(ISNA(VLOOKUP(" & FirstCell & "," & ValidationAddress & ",1,FALSE))," & FirstCell & ","""")"
    ' هنا نحول قيمة الخلاياء من معادلات الى قيم فقط
    .Value = .Value
    ' احصل على القيم و افصل كل قيمة بفاصلة منقوطة
    ListValues = Join(Application.Transpose(.Value), ",")
    ' حدث قائمة التقييم
    On Error Resume Next
        With ValidationList.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ListValues
        End With
        ' احذف قيم الاختبار
    .ClearContents
End With


Application.ScreenUpdating = True


End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


If Target.Cells.Count = 1 And Not Intersect(Target, Range("A2:A16")) Is Nothing Then
    CreateDecreasingValidationList Sheets(LISTS_SHEET).Range("A2:A16"), Sheets(Main_SHEET).Range("A2:A16")
End If
End Sub

Decreasing Validation List.zip

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

بارك الله فيك أخي الغالي أبو تراب .. إبداع متناهي..

بالنسبة للكود أشعر أن الملف ثقيل بعض الشيء ..هل هناك تعديل يمكن أن تقوم به ليكون أكثر فعالية؟؟

[ابو تراب]

هلا بالاستاذ ياسر

 

اعتقد السبب هو عبارة Application.ScreenUpdating ...الكود ينفذ بسرعة و يمكن الاستغناء عنها و خصوصا ان القائمة ليست كبيرة .. الغائها سينهي ال flickering في الشاشة

 

 

تحياتي

 

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

إخواني الكرام إليكم الإصدار الأخير ... فين الهمة يا شباب

Codes Library v1.9.4.rar

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

الأخوة الكرام إليكم الإصدار الأخير .. فيه تعديل طفيف على بعض الأكواد

 

Codes Library v1.9.5.rar

[ibn_egypt]

أستاذي الفاضل أ.ياسر

 

مرفق ملفين بهما 3 دوال برجاء اضافتهم الى المكتبة

 

الملف الأول RecordChanges

 

به دالة رائعة لتعقب أى تغييرات تحدث في ملف الإكسل وتقوم بانشاء مجلد باسم WhatChanged في القرص المحلى C وبداخله ملف نصي به كافة التغييرات التى تمت على الملف بالوقت والتاريخ وأسماء الخلايا التى تغيرت بياناتها دون أن تشعر بذلك    هى مفيدة جدا لمن يخافون من العبث بملفاتهم يمكنهم وضعها بداخله لمعرفة ما هى الخلايا التى تم العبث بها وتغييرها وما هو الوقت والتاريخ الذي تم به ذلك

 

الملف الثاني RunningWindowTasks

 

به دالتين كل دالة في موديول منفصل للتعامل مع ادارة المهام في الويندوز او ما تعرف بال Task Manager  والتى يقوم المستخدم بالضغط Alt+Ctrl+Delete للدخول اليها ومنها يمكن معرفة التطبيقات وكافة العمليات المفتوحة

 

الدالة الأولى لإيجاد كافة التطبيقات المفتوحة.. جرب افتح أى عدد من التطبيقات واضغط على زر Application In Task Manager ستظهر لك كافة التطبيقات بالكمبوبوكس الموجود بالفورم

 

الدالة الثانية .. دالة تسجيل كل ال Processes او العمليات المفتوحة للجهاز في العمود A

 

مرفق الملفات

 

تحياتي  

Nice3Functions.rar

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

أخي الحبيب ابن مصر بارك الله فيك وجزاك الله كل خير

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

شوية تطلع النتائج صحيحة وشوية غلط !

[ibn_egypt]

أخي الحبيب ابن مصر بارك الله فيك وجزاك الله كل خير

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

شوية تطلع النتائج صحيحة وشوية غلط !

استاذي الحبيب

 

الخطأ من عندي، آسف لذلك قم فقط بتغيير كلمة Selection الى Target في سطر الكود الخاص بحدث Workbook_SheetChange ..كما في الكود التالى .. هتزبط ان شاء الله

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
      LogInformation ActiveSheet.Name & Target.Address & " Changed: " & _
                     " " & Format(Now, "dd mmm yyyy hh:mm:ss")
End Sub

تحياتي  

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

جزيت خيراً أخي الحبيب جزيت كل خير على كل ما تقدمه من إسهامات من شأنها أن ترقى بمستوى المشروع إلى المستوى الاحترافي

جعل الله أعمالك في ميزان حسناتك

وتشكر على التصحيح واعذرني إني بجرب الملف وأفليه .. إنت عارف إني لازم أشتغل فلاية .. أصل الأكواد عندي بتعدي على فلاااااااااااااااتر (فلاااااتر يا مصريين)

[الجموعي]

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

أستاذي الكريم ياسر أعرف ان الموضوع مكرر

أرجو أن تقبل هذا التعديل والشرح على كود فهرس الألوان

Sub ShowColorIndexNums()
    '[I] ,[N] إعلان متغيرين
    Dim I, N As Integer
    ' القيمة 0= [N] حيث المتغير
        N = 0
    ' إضافة ورقة عمل جديدة قبل الورقة الأولى
    Worksheets.Add before:=Sheets(1)
    ' قيمة النص المدرج بين تنصيصين = [A1]قيمة الخلية
    'اللون 6 من فهرس الألوان ال 58 لونا = [A1]تعبئة الخلية
    [A1].Value = "Color": [A1].Interior.ColorIndex = 6
    ' قيمة النص المدرج بين تنصيصين = [B1]قيمة الخلية
    'اللون 6 من فهرس الألوان ال 58 لونا = [B1]تعبئة الخلية
    [B1].Value = "Index Number": [B1].Interior.ColorIndex = 6
    'إسم ورقة العمل = قيمة النص المدرج بين تنصيصين
    ActiveSheet.Name = "ColorIndex"
    ' [I]حلقة تكرارية للمتغير
    For I = 2 To 58
    '[N]فهرس الألوان  إبتداء من قيمة المتغير = [I]الي غاية أخر رقم في المتغير [A] قيمة العمود
        Range("A" & I).Interior.ColorIndex = N
    '[N]قيمة النص المدرج بين تنصيصين إبتداء من قيمة المتغير = [I]الي غاية أخر رقم في المتغير [A] قيمة العمود
        Range("A" & I).Value = "[Color " & N & "]"
    '[N]فهرس الألوان  إبتداء من قيمة المتغير = [I]الي غاية أخر رقم في المتغير [B] قيمة العمود
         Range("B" & I).Value = "[Color " & N & "]"
    '[N]لون الخط في فهرس الألوان  إبتداء من قيمة المتغير  = [I]الي غاية أخر رقم في المتغير [B] قيمة العمود
        Range("B" & I).Font.ColorIndex = N
        'ضبط محاذة النص = توسيط [I] الي غاية أخر رقم في المتغير [A1:B1] قيمة الخلايا
        Range("A1:B1" & I).HorizontalAlignment = xlCenter
        '1 +[N]القيمة = [N] حيث المتغير
        N = N + 1
    ' التالي
    Next I
    'إحتواء تلقائي لعرض العمود[B:B]في الورقة النشطة في كامل العمود
    ActiveSheet.[B:B].EntireColumn.AutoFit

End Sub

المرفق

 

Color Index.rar

[ابو تراب]

كود لتحويل امتداد الملف من XLSM الى XLSX (اي ملف بدون اكواد)

 

ملف مرفق للتطبيق

 

Public Sub ConvertXLSMtoXLSX()


' عرف متغيرات تشير للملف الحالي
Dim SourceFile As String: SourceFile = ThisWorkbook.FullName
Dim SourceName As String: SourceName = ThisWorkbook.Name
Dim SourcePath As String: SourcePath = ThisWorkbook.Path & "\"


' عرف ملف مؤقت من اجل التحويل
Dim TempFile As String:  TempFile = Replace(SourceFile, ".xlsm", "_TEMP.xlsm")




Application.DisplayAlerts = False


' احفظ الملف اولا
ThisWorkbook.Save


' عرف متغير للوصول لملفات
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")


' احذف الملف المؤقت اذا وجد
On Error Resume Next
fso.deletefile TempFile, True
On Error GoTo 0


' اعمل نسخة من الملف الحالي
fso.CopyFile SourceFile, TempFile, True


' افتح النسخة المؤقتة
Dim TempWB As Workbook
Set TempWB = Workbooks.Open(TempFile)


' احفظ بأسم و حول امتداد الملف
ActiveWorkbook.SaveAs Filename:=SourcePath & Left(SourceName, Len(SourceName) - 5) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' اغلق النسخة
TempWB.Close



Application.DisplayAlerts = True


' احذف النسخة المؤقتة
On Error Resume Next
fso.deletefile TempFile, True
On Error GoTo 0



End Sub

 

Convert XLSM to XLSX.zip

[إبراهيم ابوليله]

الاخوه الكرام

طبعا من بدأ عرض فكره استخدام TAG هو الاخ الجموعى

بارك الله فيه

ولكن اسمحو لى بعرض مثال يبسط الفكره اكثر

وهذا من وجهه نظرى

تقبلو تحياتى

Private Sub CommandButton1_Click()
Dim Ctl As Control
Dim Ctl1 As Control
Dim i As Integer
Dim i1 As Integer
For Each Ctl In UserForm1.Controls
    If Not Ctl.Tag = "" Then
        For i1 = 1 To 1
        '  åäÇ íÊã ÇÚØÇÁ Çááæä ÇáÇÍãÑ áÇì ßäÊÑæá ÞíãÉ ÇáÊÇÌ ÝíåÇ ÊÓÇæì ÇáÑÞã 1
            If Ctl.Tag = i1 Then
                Ctl.BackColor = vbRed
End If
        Next
               For i = 2 To 4
                       '  åäÇ íÊã ÇÚØÇÁ Çááæä ÇáÇÕÝÑ áÇì ßäÊÑæá ÞíãÉ ÇáÊÇÌ ÝíåÇ ÊäÍÕÑ Èíä ÇáÑÞã 2 æÇáÑÞã 4

            If Ctl.Tag = i Then
               Ctl.BackColor = vbYellow
                   End If
                 Next
    End If
Next

End Sub

TAG.rar

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

بارك الله فيكم إخواني الكرام

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

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

تقبلوا تحياتي

[الجموعي]

تكمله بخصوص التعامل مع الألوان بواسطة الأكواد

أقدم لكم كود

كود تلوين تبويبات الأوراق بضغطه زر واحدة

Sub Change_Sheet_Tab_ِColor()
'خاص بفهرس الألوان[Color] إعلان متغير
Dim Color As Integer
'خاص بأوراق العمل[WS] إعلان متغير
Dim WS As Worksheet
'القيمة 0= [Color] حيث المتغير
Color = 0
'عند وجود اخطاءإنتقل التالي
On Error Resume Next
' الحلقة التكرارية للبحث في أوراق العمل
For Each WS In Worksheets
'[Color]فهرس الألوان إبتداء من قيمة المتغير  = [WS] لون تبويب أوراق العمل
WS.Tab.ColorIndex = Color
'1 +[Color]القيمة = [Color] حيث المتغير
Color = Color + 1
' التالي
Next
End Sub

الملف المرفق

Change_Sheet_Tab_ِColor.rar

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

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

بعثت إليك برسالة خاصة .. يرجى مراجعة الخاص

بارك الله فيك

[ibn_egypt]

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

 

كثيرا ما كان يزعجنى في الفورم رسالة التنبيه الملحقة بخاصية ال Match Required الخاصة بالكمبو بوكس بالرغم من أهميتها الشديدة لإلزام المستخدم من الاختيار من القائمة .... ولكن عند الوقوف على الكمبو والضغط على زر خروج تظهر رسالة Invalid Property Value >>> وتستمر في الظهور الى ان اختار اى عنصر من الكمبو

 

مرفق كود بسيط لاظهار رسالة خطأ اذا تم كتابة اى عنصر ليس موجودا بالكمبو .. أى بديل لخاصية ال Match Required ورسالتها المزعجة ... أدعوا الله ان يجازى صاحبه عنا خير الجزاء

 

تحياتي   

Select-From-Combobox.rar

[ابو تراب]

جزاك الله خيرا استاذ ابن مصر على مشاركتنا الكود

 

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

 

على كلا و اثراء للموضوع يمكن ايضا استخدام حاصية ComboBox1.MatchFound

 

تقبل تحياتي و شكري 

 

 

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

جرب أخي الغالي بان مصر تكتب حرف واحد وتضغط Enter....

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

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

 

Codes Library v1.9.6.rar

[طارق_نادر]

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

Sub PrintSelectedSheets()
'   Display "Printer Setup" dialog box
    Application.Dialogs(xlDialogPrinterSetup).Show
'   Option Explicit
'   Sub SelectSheets()
    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
    Application.ScreenUpdating = False
'   Check for protected workbook
    If ActiveWorkbook.ProtectStructure Then
        MsgBox "Workbook is protected.", vbCritical
        Exit Sub
    End If
'   Add a temporary dialog sheet
    Set CurrentSheet = ActiveSheet
    X = CurrentSheet.Name
    Set PrintDlg = ActiveWorkbook.DialogSheets.Add
    SheetCount = 0
'   Add the checkboxes
    TopPos = 40
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'       Skip empty sheets and hidden sheets
        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
'   Move the OK and Cancel buttons
    PrintDlg.Buttons.Left = 240
'   Set dialog height, width, and caption
    With PrintDlg.DialogFrame
        .Height = Application.Max _
            (68, PrintDlg.DialogFrame.Top + TopPos - 34)
        .Width = 230
        .Caption = "Select sheets to print"
    End With
'   Change tab order of OK and Cancel buttons
'   so the 1st option button will have the focus
    PrintDlg.Buttons("Button 2").BringToFront
    PrintDlg.Buttons("Button 3").BringToFront
'   Get the number of print copies for each report
    Numcop = Application.InputBox("Enter number of copies to print:", _
    "How Many Copies?", 1, Type:=1)
    If Numcop = 0 Then
    ElseIf Len(Numcop) > 0 Then
        End If
'   Display the dialog box
    CurrentSheet.Activate
    Dim cnt As Integer
    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 ' Replace:=False 'Activate
                Else
                    Worksheets(cb.Caption).Select Replace:=False 'Activate
                End If
                    cnt = cnt + 1
                End If
                Next cb
                    ActiveWindow.SelectedSheets.PrintOut copies:=Numcop
                    'ActiveSheet.PrintPreview 'for debugging
        End If
    Else
        MsgBox "All worksheets are empty."
    End If
'   Delete temporary dialog sheet (without a warning)
    Application.DisplayAlerts = False
    PrintDlg.Delete
'   Reactivate original sheet
    Sheets(X).Select
End Sub