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

[KHMB]

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

ولإثـــــــراء المكتبه هذا كود لاحظت الكثير يسألوا ويبحثوا عنة ولم يلقوا إجابه وهذا الكود يقوم بحذف الملف نهائيا بعد إستخدامة 3 مرات مع إمكانية تغيير العدد

الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف.rar

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

جزيت خيراً أخي الحبيب

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

سأقوم بتحميل النسخة الأخيرة ليلاً إن شاء الله

بارك الله فيك أخي (اللي مش عارف اسمه) بس بيعجبني مواضيعك المتميزة

يا ريت كل يوم كود واحد منك إسهاماً في المشروع الكبير

تقبل تحياتي

[جلال محمد]

اخي ياسر 

السلام عليكم 

ارجو ان تقبل مني هذة المشاركة 

ارجوا من الله العلي القدير ان يجعل اعمالك في موازين حسناتك

وان ينفع بها الناس 

Codes Library v1.3.rar

[Yasser Fathi Albanna]

أحببت أن أشارك معكم هذا العمل العظيم وجدت هذا العمل ضمن بحثى داخل الإنترنت

ولكن بالإنجليزى

يا ريت ينال إعجابكم ويستفاد منه الجميع

 

VBAcodeLibrary.rar

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

الأخ الحبيب جلال محمد بارك الله فيك وجزاك الله خير الجزاء

الأخ ياسر جزيت خيرا على هذا الملف الرائع فهو يحوي الدرر ..

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

Codes Library v1.4.rar

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

السلام عليكم

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

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

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

وفق الله الجميع لما فيه خير الناس اجمعين

دمتم برعاية الله وحفظه

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

أخي وأستاذي محمد أبو عباس

مينفعش تدخل وايدك فاضية .............. لازم تشارك ولو بكود (تشجيعك لوحده مش كفاية ..شارك ولو بكود) .في الانتظار !!!!!!!!أنا قاعد جنب الجهاز لحد ما أشوف الكود

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

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

اخي واستاذي الحبيب ابو البراء جزاك الله خيرا

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

( مينفعش تدخل وايدك فاضية)  

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

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

هذا فوق قابليتي ارجو قبول اعتذاري

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

دمتم في رعاية الله وحفظه

  

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

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Static OldCell As Range

If Not OldCell Is Nothing Then
OldCell.Interior.ColorIndex = xlColorIndexNone
End If

Target.Interior.ColorIndex = 6

Set OldCell = Target


End Sub

السلام عليكم

اخي الحبيب ابو البراء زادكم الله من فضله علما وشرفا

هذه مشاركة بسيطة عشان ماتبقاش جنب  الجهاز بخاف على نظرك انت عزيز علينا

وهو كود تلوين الخلية النشطة 

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

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

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

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

إن شاء الله بعد ما يكتمل العمل قليلاً ستحس بالفرق

تقبل تحياتي (وياريت تبقا تزورنا كل يوم بكود ..لو صعب يبقا كودين كل يوم ..لو شايف إن دا هيكون أمر مستحيل يبقا تجيب معاك 3 أكواد كل يوم)

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

إخواني الكرام بدون ما أكتر في الكلام أخذاً بنصيحة أخي في الله خالد

تفضلوا الإصدار الأخير (تمت إضافة حوالي 11 كود)

Codes Library v1.5.rar

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

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

الاستاذ والاخ الحبيب ابو البراء جزاكم الله خيرا

قرات جميع الاكواد المرفقة في الاصدار الاخير من مكتبة الاكواد في المشاركة 36

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

لاخفاء الصفوف اذا كانت الخلية صفر او فراغ وحسب نطاق محدد او نغيره الى تحديد يدوي وباي شيت من المصنف

ارجو ان يفي بالغرض ويستفيد منه الاخوة الاعزاء

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

Sub HideBlankRows()
 ' اذا كان النطاق معلوم ومحدد غير النطاق حسب بياناتك
'Dim rng As Range
'Dim cell As Range
'Set rng = Range("A4:A100")
'For Each cell In rng
' هنا حسب التحديد  "نحدد النطاق" ويجب ان يكون في عمود واحد فقط وباي شيت من المصنف ثم نشغل الكود
For Each cell In Selection
'هذا هو الكود يعمل على الخاصيتين حسب حاجتكم
    If cell.Value = 0 Or cell.Value = "" Then
        cell.EntireRow.Hidden = True
    End If
Next cell
End SubSub ShowAll()

    هذا الكود لاظهار الصفوف المخفية

Sub ShowAll()
    Application.ScreenUpdating = False
    On Error Resume Next
        ActiveSheet.ShowAllData
    Application.ScreenUpdating = True
End Sub

تم تعديل يناير 3, 2015 بواسطه أبو محمد عباس

[عبدالله المجرب]

السلام عليكم 

احببت ان اسجل اعجابي بالفكرة والجهد الكبير الذي تبذله استاذ ياسر 

=====

وهذا الكود البسيط عشان ما تقولي ايدي فاضية 

 

=====

Sub Abu_Ahmed_Del()
LR = [A1000].End(xlUp).Row
For i = LR To 1 Step -1
If Application.CountIf(Range("A1:A" & LR), Cells(i, 1)) > 1 Then Cells(i, 1).Delete Shift:=xlUp
   Next
End Sub

الكود يقوم بحذف المكرر من القيم والابقاء على قيمة واحدة فقط 
ويعمل على مدى مفتوح 
ولا يقوم بحذف الصف بالكامل وانما يقوم بالحذف بطريقة الازاحة الى اعلى

[شوقي ربيع]

السلام عليكم

مولد نبوي شريف ومبارك وعام سعيد على كل الامة العريبة

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

اعتذر عن تأخري في المساهمة في هذا الموضوع المميز

وكبداية اقدم هذا الكود البسيط الذي طرحته سابقا في احد طلبات الاعضاء

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

Private Sub CommandButton1_Click()
Dim Tableau() As Variant: Tableau() = ListBox1.List
Dim i As Integer: i = ListBox1.ListCount
Dim j As Byte: j = ListBox1.ColumnCount
Application.DisplayAlerts = False
    Workbooks.Add
    Range("A1:" & Cells(i, j).Address) = Tableau()
    ActiveWorkbook.PrintOut
    ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub

تحياتي للجميع

والى اكواد اخرى ان شاء الله

 

Printe listbox.rar

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

إخواني الأحباب

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

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

أسأل الله العلي القدير أن ينفع بنا ويجعل عملنا في ميزان حسناتنا يوم القيامة

 

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

الأخ الحبيب عبد الله المجرب تسلم على الكود الرائع ، ولا تنسانا من روائعك المتميزة

أما أنت يا أخي شوقي أما أنت فلا أجد لك كلمة أعبر لك بها عن فرحتي وسعادتي بمشاركتك وأرجو أن تكمل فرحتي بطلبين : الأول : المشاركة يومياً في الموضوع اسهاما منك في هذا المشروع الكبير الذي لطالما حلمت به وها هو بحمد الله بدأت بوادره في الظهور .. الطلب الثاني أن يكون الكود مدعوم بالشرح حتى تكون المكتبة زاخرة عامرة بالأكواد المفهومة لدى الناس

تقبلوا تحياتي إخواني الأعزاء

إليكم تجميعة اليوم 8 أكواد (بما فيها أكواد الأساتذة الكرام مع شرح مبسط لما استطعت شرحه)

أترككم مع النسخة الأخيرة ، انسى اللي فات اعمل Delete ومتسيفش اللي فات ، خليك مع الجديد يا أبو عيد

 

Codes Library v1.6.rar

[شوقي ربيع]

السلام عليكم

تحية كبيرة لاخ ياسر

بخصوص قبول TextBox لحروف فقط أو أرقام فقط

افضل الاتي

 

1 لجعل التكست  بوكس لاتقبل الا الارقام

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[!0-9]" Then KeyAscii = 0
End Sub

2 لجعل التكست بوكس لاتقبل الا الحرف الانجليزية الصغيرة

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[!a-z]" Then KeyAscii = 0
End Sub

3 لجعل التكست  بوكس لاتقبل الا الحروف الانجليزية الكبيرة

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[!A-Z]" Then KeyAscii = 0
End Sub

4 لجعل التكست تقبل الا الحروف الانجليزية الصغيرة والكبيرة معا

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[!A-z]" Then KeyAscii = 0
End Sub

5 لجعل التكست بوكس لا تقبل الا الحروف العربية

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[!أ-ي]" And ChrW(KeyAscii) <> " " Then KeyAscii = 0
End Sub

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

مثال

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[! A-Z]" Then KeyAscii = 0
End Sub

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

هذا مثال لايقبل الا الحروف الانجليزة الكبيرة والمسافة وهته الاشارات =:;/.

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If ChrW(KeyAscii) Like "[! A=:;/-Z]" Then KeyAscii = 0
End Sub

تحياتي للجميع

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

تسلم أخي الحبيب شوقي على هذه الأكواد الرائعة

تمت الإضافة في الإصدار القادم بإذن الله

ولا تنسى الحكمة التي تقول (قليل دائم خير من كثير منقطع)

[شوقي ربيع]

 

 (قليل دائم خير من كثير منقطع)

 

ان شاء الله سيكون كثيرا دائم

[مختار حسين محمود]

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

التالى كود لدق أرقام سرية أو عمل ترقيم تلقائى

Sub AutoNumbering()

ActiveCell = ActiveCelltiveCell
NS:
A = Application.InputBox("أدخل أول رقم فى السلسلة التى تريد إنشاؤها", "     ")
B = Application.InputBox("أدخل آخر رقم فى السلسلة التى تريد إنشاؤها", "      ")

If A = False Or B = False Then
Exit Sub
ElseIf A = "" Or B = "" Then
MsgBox "!تأكد من إدخال الأرقام بشكل صحيح", vbExclamation, "إدخال خاطئ"
Else

If [IV65536] = 1 Then
ActiveCell = A
Else: Columns(ActiveCell.Column).Rows(65536).End(xlUp).Select
If ActiveCell = "" Then
ActiveCell = A
Else: ActiveCell.Offset(1, 0).Select
Selection = A
End If
End If
ActiveCell.DataSeries xlColumns, , , 1, B
End If

If Application.WorksheetFunction.CountA(Columns(ActiveCell.Column)) = 1 Then
ActiveCell.ClearContents
Beep
If MsgBox("أول رقم فى السلسلة أكبر من آخر رقم ... هل تود إعادة المحاولة ؟", vbQuestion + vbYesNo, " إدخال خاطئ") = vbNo Then
Exit Sub
Else: GoTo NS
End If
End If

Beep
If MsgBox("هل تود إنشاء سلسلة رقمية أخرى ؟", vbYesNo + vbQuestion, "إنشاء سلسلة أخرى") = vbNo Then
Exit Sub

Else: GoTo NS

End If
End Sub

تحياتى للجميع

تم تعديل يناير 3, 2015 بواسطه مختار حسين محمود

[numanawwad]

السلام عليكم التالي محفظة اكواد احد اعضاء المتتدى وجدتها بالمنتدى الكريم

محفظة اكواد___النسخة1.rar

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

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

الأخ الفاضل نعمان عوض ..

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

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

الأخ الحبيب مختار ..

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

وننتظر منك المزيد المزيد (رحم الله والديك وغفر لهما وجعل الجنة مثواهما)

أريدك سنداً لي في المشروع فلا تخذلني

 

[احمد عبدة]

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

وبشكر الاستاذ 

YasserKhalil

على الموضوع الاكثر من رائع  

المنتدى اتعلمت منة الكثير وطور ادائى فى العمل بشكل كبير

بشكر تانى المنتدى وكل القائممين علية وكل الاعضاء والمشاركين فية

 

تحياتى للجميع

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

نورت الموضوع بمرورك العطر أخي أحمد عبده

بارك الله فيك ، وفي انتظار المشاركة منك في المكتبة

[شوقي ربيع]

السلام عليكم

دالة استخراج اخر يوم من الشهر

Function NB_JOURS(date_test As Date)
    NB_JOURS = Day(DateSerial(Year(date_test), Month(date_test) + 1, 1) - 1)
End Function

ضع الكود في موديل ثم في ورقة العمل أدرج الدالة كاي دالة اخرى تجدها باسم NB_JOURS

السيغة العامة لدالة تكون

=NB_JOURS(A1)

تحياتي

[شوقي ربيع]

السلام عليكم

كود لتوليد كود عشوائي (سيريل نمبر عشوائي)

Sub Code_Aléatoire()
    Randomize
Dim sCarac  As String: sCarac = "ABCDEFGKHLMNPQRSTWXYZ0123456789"
Dim sLettre As String: sLettre = ""
Dim bI As Byte, bNombre As Byte
     
    For bI = 1 To 20
        bNombre = Int(Len(sCarac) * Rnd) + 1
        sLettre = sLettre & Mid(sCarac, bNombre, 1)
    If bI Mod 5 = 0 Then sLettre = sLettre & "-"
    Next
MsgBox Mid(sLettre, 1, 23)

End Sub

تحياتي