KHMB قام بنشر يناير 1, 2015 قام بنشر يناير 1, 2015 السلام عليكم ورحمة الله ولإثـــــــراء المكتبه هذا كود لاحظت الكثير يسألوا ويبحثوا عنة ولم يلقوا إجابه وهذا الكود يقوم بحذف الملف نهائيا بعد إستخدامة 3 مرات مع إمكانية تغيير العدد الملف يحذف نفسه تلقائيا بعد 3 استعمالات و يشعر المستخدم بعد الحذف.rar 1
ياسر خليل أبو البراء قام بنشر يناير 1, 2015 الكاتب قام بنشر يناير 1, 2015 جزيت خيراً أخي الحبيب قبل أن تقوم بمشاركتك أعجبني فكرة الكود فقمت بإضافته على الفور في مكتبة الصرح سأقوم بتحميل النسخة الأخيرة ليلاً إن شاء الله بارك الله فيك أخي (اللي مش عارف اسمه) بس بيعجبني مواضيعك المتميزة يا ريت كل يوم كود واحد منك إسهاماً في المشروع الكبير تقبل تحياتي
جلال محمد قام بنشر يناير 1, 2015 قام بنشر يناير 1, 2015 اخي ياسر السلام عليكم ارجو ان تقبل مني هذة المشاركة ارجوا من الله العلي القدير ان يجعل اعمالك في موازين حسناتك وان ينفع بها الناس Codes Library v1.3.rar 2
Yasser Fathi Albanna قام بنشر يناير 1, 2015 قام بنشر يناير 1, 2015 أحببت أن أشارك معكم هذا العمل العظيم وجدت هذا العمل ضمن بحثى داخل الإنترنت ولكن بالإنجليزى يا ريت ينال إعجابكم ويستفاد منه الجميع VBAcodeLibrary.rar 1
ياسر خليل أبو البراء قام بنشر يناير 1, 2015 الكاتب قام بنشر يناير 1, 2015 الأخ الحبيب جلال محمد بارك الله فيك وجزاك الله خير الجزاء الأخ ياسر جزيت خيرا على هذا الملف الرائع فهو يحوي الدرر .. تفضلوا إخواني الإصدار الأخير من المكتبة ..فيها مجموعة جديدة أخرى من الأكواد Codes Library v1.4.rar 1
أبو محمد عباس قام بنشر يناير 2, 2015 قام بنشر يناير 2, 2015 السلام عليكم رائع استاذ ابو البراء مواضيعكم فيها فائدة كبيرة جعلها الله في ميزان حسناتكم وكل الحب والاحترام والتقدير للاساتذة والاخوة الذين شاركو باثراء هذه المكتبة الرائعة وفق الله الجميع لما فيه خير الناس اجمعين دمتم برعاية الله وحفظه 1
ياسر خليل أبو البراء قام بنشر يناير 2, 2015 الكاتب قام بنشر يناير 2, 2015 أخي وأستاذي محمد أبو عباس مينفعش تدخل وايدك فاضية .............. لازم تشارك ولو بكود (تشجيعك لوحده مش كفاية ..شارك ولو بكود) .في الانتظار !!!!!!!!أنا قاعد جنب الجهاز لحد ما أشوف الكود
أبو محمد عباس قام بنشر يناير 2, 2015 قام بنشر يناير 2, 2015 السلام عليكم ورحمة الله وبركاته اخي واستاذي الحبيب ابو البراء جزاك الله خيرا صدقني سبب تاخري عن الرد لحد مشاركتي السابقة بالرغم من متابعة المواضيع من اول مشاركة كان سببه هو ( مينفعش تدخل وايدك فاضية) انا خبرتي جدا قليله بالاكواد يادوب تعلمت منكم ومن اساتذتنا بعض الاكواد والتعديل عليها اما كتابة كاملة وباحتراف هذا فوق قابليتي ارجو قبول اعتذاري ويمكن المشاركة مستقبلا في بعض الاكواد المنقوله او المعدلة دمتم في رعاية الله وحفظه
أبو محمد عباس قام بنشر يناير 2, 2015 قام بنشر يناير 2, 2015 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
ياسر خليل أبو البراء قام بنشر يناير 2, 2015 الكاتب قام بنشر يناير 2, 2015 تسلم أخي الحبيب محمد أبو عباس الأكواد منقولة منقولة ..ما كلنا بننقل أو معظمنا .. نشوف المفيد اللي نقدر نفيد بيه غيرنا ونضعه بالمكتبة ..يبقا مرجع للجميع إن شاء الله بعد ما يكتمل العمل قليلاً ستحس بالفرق تقبل تحياتي (وياريت تبقا تزورنا كل يوم بكود ..لو صعب يبقا كودين كل يوم ..لو شايف إن دا هيكون أمر مستحيل يبقا تجيب معاك 3 أكواد كل يوم) 2
ياسر خليل أبو البراء قام بنشر يناير 2, 2015 الكاتب قام بنشر يناير 2, 2015 إخواني الكرام بدون ما أكتر في الكلام أخذاً بنصيحة أخي في الله خالد تفضلوا الإصدار الأخير (تمت إضافة حوالي 11 كود) Codes Library v1.5.rar 2
أبو محمد عباس قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 (معدل) السلام عليكم ورحمة الله وبركاته الاستاذ والاخ الحبيب ابو البراء جزاكم الله خيرا قرات جميع الاكواد المرفقة في الاصدار الاخير من مكتبة الاكواد في المشاركة 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 بواسطه أبو محمد عباس 1
عبدالله المجرب قام بنشر يناير 3, 2015 قام بنشر يناير 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 الكود يقوم بحذف المكرر من القيم والابقاء على قيمة واحدة فقط ويعمل على مدى مفتوح ولا يقوم بحذف الصف بالكامل وانما يقوم بالحذف بطريقة الازاحة الى اعلى 1
شوقي ربيع قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 السلام عليكم مولد نبوي شريف ومبارك وعام سعيد على كل الامة العريبة الشكر موصول للاخ والاستاد العزيز ياسر على الجهد الذي يبذله وكل الاعضاء الذين يشاركون في الموضوع اعتذر عن تأخري في المساهمة في هذا الموضوع المميز وكبداية اقدم هذا الكود البسيط الذي طرحته سابقا في احد طلبات الاعضاء طباعة محتوى اليست بوكس من الفورم 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 1
ياسر خليل أبو البراء قام بنشر يناير 3, 2015 الكاتب قام بنشر يناير 3, 2015 إخواني الأحباب لكم يشرفني ويسعدني مرور كبار المنتدى وأساتذتي الأجلاء على الموضوع ، والله إنه لشرف لي أن يشاركوا فيه .. ولكم أتمنى مداومة المشاركة حتى يخرج العمل في النهاية بأفضل صورة ويستفيد منه الجميع الكبير قبل الصغير والخبير قبل المبتديء .. أسأل الله العلي القدير أن ينفع بنا ويجعل عملنا في ميزان حسناتنا يوم القيامة الأخ الحبيب أبو محمد عباس تسلم على الكود الرائع وانتظر مني كود مشابه لنفس العمل ولكن ... سأذكر فيما بعد الأخ الحبيب عبد الله المجرب تسلم على الكود الرائع ، ولا تنسانا من روائعك المتميزة أما أنت يا أخي شوقي أما أنت فلا أجد لك كلمة أعبر لك بها عن فرحتي وسعادتي بمشاركتك وأرجو أن تكمل فرحتي بطلبين : الأول : المشاركة يومياً في الموضوع اسهاما منك في هذا المشروع الكبير الذي لطالما حلمت به وها هو بحمد الله بدأت بوادره في الظهور .. الطلب الثاني أن يكون الكود مدعوم بالشرح حتى تكون المكتبة زاخرة عامرة بالأكواد المفهومة لدى الناس تقبلوا تحياتي إخواني الأعزاء إليكم تجميعة اليوم 8 أكواد (بما فيها أكواد الأساتذة الكرام مع شرح مبسط لما استطعت شرحه) أترككم مع النسخة الأخيرة ، انسى اللي فات اعمل Delete ومتسيفش اللي فات ، خليك مع الجديد يا أبو عيد Codes Library v1.6.rar 1
شوقي ربيع قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 السلام عليكم تحية كبيرة لاخ ياسر بخصوص قبول 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 تحياتي للجميع 6
ياسر خليل أبو البراء قام بنشر يناير 3, 2015 الكاتب قام بنشر يناير 3, 2015 تسلم أخي الحبيب شوقي على هذه الأكواد الرائعة تمت الإضافة في الإصدار القادم بإذن الله ولا تنسى الحكمة التي تقول (قليل دائم خير من كثير منقطع) 3
شوقي ربيع قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 (قليل دائم خير من كثير منقطع) ان شاء الله سيكون كثيرا دائم
مختار حسين محمود قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 (معدل) السلام عليكم ورحمة الله وبركاته التالى كود لدق أرقام سرية أو عمل ترقيم تلقائى 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 بواسطه مختار حسين محمود 1
numanawwad قام بنشر يناير 3, 2015 قام بنشر يناير 3, 2015 (معدل) السلام عليكم التالي محفظة اكواد احد اعضاء المتتدى وجدتها بالمنتدى الكريم محفظة اكواد___النسخة1.rar تم تعديل يناير 3, 2015 بواسطه numanawwad
ياسر خليل أبو البراء قام بنشر يناير 3, 2015 الكاتب قام بنشر يناير 3, 2015 الأخ الفاضل نعمان عوض .. فكرة الموضوع ليست بجديدة على الإطلاق ..الفكرة نفذت من قبل ، لكنها لم تجد المتابعة الجيدة من ناحية ،و من ناحية أخرى لا يوجد بها شروحات كما بالإصدارات التي تقدم الآن. الآن بعون الله وتوفيقه بدأت فكرة المشروع تظهر بوادرها وإن شاء الله قريباً سيكتمل المشروع ويكون نبراسا للجميع ، ويسهل عملية البحث والتطبيق والتنفيذ الأخ الحبيب مختار .. جزيت خير الجزاء على هذا الكود الرائع ..وإن كان طويلاً بعض الشيء ..ونريد شرحاً وافياً لكل أسطر الكود كي يستفاد منه أقصى اسستفادة وننتظر منك المزيد المزيد (رحم الله والديك وغفر لهما وجعل الجنة مثواهما) أريدك سنداً لي في المشروع فلا تخذلني 1
احمد عبدة قام بنشر يناير 4, 2015 قام بنشر يناير 4, 2015 والله ياجماعة انا بشكر المنتدى الجميل دا وبشكر الاستاذ YasserKhalil على الموضوع الاكثر من رائع المنتدى اتعلمت منة الكثير وطور ادائى فى العمل بشكل كبير بشكر تانى المنتدى وكل القائممين علية وكل الاعضاء والمشاركين فية تحياتى للجميع 1
ياسر خليل أبو البراء قام بنشر يناير 4, 2015 الكاتب قام بنشر يناير 4, 2015 نورت الموضوع بمرورك العطر أخي أحمد عبده بارك الله فيك ، وفي انتظار المشاركة منك في المكتبة
شوقي ربيع قام بنشر يناير 4, 2015 قام بنشر يناير 4, 2015 السلام عليكم دالة استخراج اخر يوم من الشهر 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) تحياتي 1
شوقي ربيع قام بنشر يناير 4, 2015 قام بنشر يناير 4, 2015 السلام عليكم كود لتوليد كود عشوائي (سيريل نمبر عشوائي) 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 تحياتي 1
الردود الموصى بها