الجموعي

أخى الفاضل أ.الجموعي لا أجيد الشرح ولكن هذه محاولة مني لإيصال الفكرة...أرجو أن أكون وفقت في ذلك Sub GetUniques() 'عند حدوث أى خطأ يذهب الى 1 'وهناك ننهي الكود On Error GoTo 1 'تعريف المتغيرات Dim S As Object, c, m As Variant, i, k, LastR, LastR2 As Long, ws, ws2 As Worksheet Application.ScreenUpdating = False 'تعريف ورقة العمل التى سنجلب منها القائمة المنسدلة Set ws = ThisWorkbook.Sheets("المبيعاتSales") 'تعريف ال 'Scripting Dictionary 'الذي سيحوي البيانات الفريدة Set S = CreateObject("Scripting.Dictionary") 'تعريف الورقة التى ستكون بها القائمة المنسدلة Set ws2 = ThisWorkbook.Sheets("كشف حساب عميل") 'ايجاد اخر صف بالورقة التى سنحضر منها البيانات LastR = ws.Cells(Rows.Count, 4).End(xlUp).Row 'عمل حلقة تكرارية من بداية النطاق الذي به البيانات حتى اخر صف بهذا النطاق 'القيم الفريدة يتم وضعها في ال 'Scripting Dictionary 'حتى يتم ايجاد البيانات بدون أى تكرار m = ws.Range("D4:D" & LastR) For k = 1 To UBound(m, 1) S(m(k, 1)) = 1 Next k 'أصبح لدينا الآن 'Scripting Dictionary 'يحوي القيم الفريدة في النطاق الذي حددناه 'نذهب الى ورقتنا الأصلية التى ستحوي القائمة المنسدلة 'نمسح البيانات من 'z500 to z700 ws2.Range("Z500:Z700").ClearContents 'نحذف القائمة المنسدلة الموجودة بالخلية 'F1 ws2.Range("F1").Validation.Delete 'بنقول هنا بداية من 'Z500 'وبطول عدد القيم الموجودة بال 'Scripting Dictionary 'قم بكتابة القيم الموجودة به ws2.Range("Z500").Resize(S.Count) = Application.Transpose(S.keys) 'كده البيانات الفريدة أصبحت موجودة لديك بالشيت 'بداية من الخلية 'Z500 'نشوف قيمة آخر صف بعد ان تم وضع البيانات LastR2 = ws2.Cells(Rows.Count, "Z").End(xlUp).Row 'يتم عمل قائمة منسدلة في الخلية 'F1 'بدايتها الخلية 'z500 'ونهايتها 'z&LastR2 'الذي حصلنا عليه With ws2.Range("F1").Validation .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _ Formula1:="=$Z$500:$Z$" & LastR2 'تجاهل الفراغات في القائمة المنسدلة .IgnoreBlank = True .InCellDropdown = True End With Application.ScreenUpdating = True 1 End Sub تحياتي lماشاء الله الفكرة وصلت بارك الله فيك أستاذي الكريم قم بمراجعة مرفقك به مشكل وهو عند البحث مرة ثانية لا يمسح البيانات الأولى

انظر في حدث ال WorkSheet_Activate أخى الجموعي بنفس الورقة ( كشف حساب عميل ) تحياتي شكرا أخي الكريم ياريت شرح مبسط لهذا الكود المعقد

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

إليك ما طلبت ahmad.rar

اخي الكريم هذه المشكلة مع كامل الفورمات وليست شاشة تعديل الباسوورد

كانت المعادله الاول كدا زى ما حضرتك تفضل بها ولكن الاخت قالت انها بتعمل على 2003 ونسخة 2003 مفيهاش على ما اعتقد مش متاكد Iferror لذالك تم الاستعاضه ب IF تقبل تحياتى شكرا على التوضيح أستاذي الكريم تحياتي

أستاذي الكريم عندي تعقيب على هذه المعادلة =IF(B6="";"";VLOOKUP(B6;'بيانات الطلبة'!B7:V10000;4;0)) لماذا لا نجعل المعادلة بهذا الشكل =IFERROR( VLOOKUP(B6;DATA;4;FALSE);"") DATA = B7:V10000

تفضلي ما طلبت أختي الكريمة إسم المستخدم :admin كلمة المرور:222 واجهه كنترول للاستاذ الحسامي1.rar

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

تفضل ما طلبت إسم المستخدم : admin كلمة المرور: 1234 واجهه كنترول للاستاذ الحسامي.rar

شكرااااااااااااااااااااااااااااااااااااااا اخى الكريم ربنا يجعلو فى ميزان حسناتك بس الغى الصفحه الى بتظهر لما اكسيل يفتح دى في حدث ThisWorkbook قم بإلغاء كود تشغيل اليوز فورم Private Sub Workbook_Open() UserForm1.Show End Sub

أخي الكريم أنا أرفقت لك الملف كنموذج أنت حر إختيارك للملف الصوتي عند إختيار الملف الصوتي مثلا سورة طه لابد أن يكون إمتداد أو لا حقة الملف wav MYPATH = ThisWorkbook.Path & "\سورة طه.wav"

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

معلش حضرتك انا اسف ممكن انا مش عارف اشرح انا عايز ايه بوص انا عايز اقفل قائمة ALT+F11 خالص بباسورد عشان مش عايز حد يغير الاكواد الى جوه وعايز ملف الصوت يفضل شغال عادى لو ايه قرانية تفضل شغاله لحد لما تخلص مش عارف الى حضرتك عاملها دى بتفضل شغاله ولا بتشتغل لما افتح ملف الاكسيل بس وشكرا أخي الكريم الله أعلم لا نستطيع قفل علامة التبويب ALT+F11 كما شرح لك تقدر تقفل الموديول واليوزر فورم وكل الشيتات كما شرحت لك بالنسبة للملف الصوتي الذي أرفقته لك يعمل مع إنطلاق الفورم هو ملف صوتي قصير فيه 5 ثواني

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

تم إدراج ما طلبت في المشاركة الثانية

تفضل أخي ما طلبت ملاحظه الملف الصوتي لابد أن يكون داخل مجلد الملف بالنسبة لقفل الماكرو بباسورد شرح مصور ملف صوتي.rar ملف صوتي 2003.rar

وفيك بارك الله أخي الكريم شرح مبسط إن شاء الله يفيدك مثلا أضف مربع نص المقصود به TextBox في فورم UserForm1 ملاحظة مهمة هنا لابد من تغيير إسم التكست بوكس إلى أخر رقم في ww إنت حاليا عندك أخر رقم في تكست بوكس هو ww37 معناها عند إضافة تكست بوكس جديد قمت بتسميته بهذا الإسم ww38 الأن قم بالدخول إلى الأكواد في حدث الكمبوبوكس لا حظ الكود أخر تكست بوكس هو 37 مشار إليها بالأحمر هي الإسم ww Private Sub ComboBox1_DropButtonClick() For j = 2 To 50 If ComboBox1.Value = Sheet8.Cells(j, 2).Value Then For i = 2 To 37 Me.Controls("ww" & i).Value = Sheet8.Cells(j, i).Value Next i Exit For End If Next j End Sub كل ما علينا فعله هو إضافة رقم 38 ليصبح الكود على الشكل التالي For i = 2 To 38 وهكذا تتم العملية أيضا في زر تعديل ننتقل الان إلى اليوزر فورم الأخر والذي يحمل إسم database مثلا أضف مربع نص المقصود به TextBox هنا أنت حر بتسمية التكست بوكس بأي إسم شئت مثلا txt1 نفتح محرر الاكواد ننتقل لحدث زر ok Private Sub CommandButton1_Click() نقوم بإدراج هذا الكود في أخر شرط If Me.txt1.Value = "" Then MsgBox "أرجو إدخال وزن .......", vbExclamation, "جدول تحليل الأطعمة" Me.txt1.SetFocus Exit Sub End If ملاحظة النقاط تعني إسم الليبل الذي ستدرجه امام تكست بوكس مثلا اسم الليبل : ميلكانا عند إدراج الكود يصبح على هذا الشكل MsgBox "أرجو إدخال وزن ميلكانا", vbExclamation, "جدول تحليل الأطعمة" ننتقل الان إلى الكود التالي في نفس الحدث لاحظ هذا الكود .Offset(RowCount, 35).Value = Me.T15.Value معناها عندنا أخر عمود هو 35 وأنت أضفت عمود جديد معانها أصبح لديك 36 عمود أصبح الكود بهذا الشكل .Offset(RowCount, 36).Value = Me.txt1.Value شرح بسيط للكود القيمة التي ستدرج في العمود 36 تساوي القيمة المكتوبه في مربع النص وهكذا نفس الخطوات عند إضافة مربع نص جديد وفي الأخير أرجو الشرح ان ينال إعجابك والسلام عليكم

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

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

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

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

أين المرفق أخي ؟

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

تم التعديل إليك ما طلبت خلطاط ميلكانا.rar