نجوم المشاركات

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

ربما يفيدك هذه المجهودات السابقة جزاهم الله كل خير ملفات الخطوط وملفات القرآن وورد واكسل و txt & sql والكثير من الامتدادات ولجميع القراءات منصة مطوري برمجيات القرآن الكريم – مجمع الملك فهد لطباعة المصحف الشريف (qurancomplex.gov.sa) بالتوفيق للجميع

اخي @mahmoud nasr alhasany بما ان الكود يعطي نتائج صحيحة ومرضية بالنسبة لك لا حاجة لتغييره هناك ملاحظة بسيطة اظن انك لم تقرأ الكود جيدا يمكنك الاستغناء عن كود التهيئة Private Sub UserForm_Initialize() لقد تمت اظافة افراغ و تنسيق اعمدة الليست بوكس مسبقا على الكود لا حاجة لتكراره ما دمت ترغب باختصار الاكواد Private Sub CommandButton3_Click() Dim x() As Variant Set f = Sheets(1): x = Array("ListBox1", "ListBox2") 'تفريغ عناصر الليست بوكس For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i 'Code ...... ................... ' تحديد عدد وعرض الاعمدة على الليست بوكس For i = 0 To UBound(x) With Me.Controls(x(i)) .ColumnCount = 5: .ColumnWidths = "50;60;65;50;95" End With Next i End Sub '=================================================== Private Sub CommandButton1_Click() ' اضف هدا في اخر الكود ليتم الغاء تحديد العناصر بعد تنفيده 'Code....... ...... For s = 1 To 4 Me("OptionButton" & s).Value = False Next End Sub message for expiring items1 V5.xlsm

Gemini API.accdb

برنامج بسيط للتجربة 1- تحكم كامل بالفورم من تحريك النافذه وتغير الحجم عند تحريك مؤشر المواس لحواف النافذه 2-عرض القوائم مع سلاسه عند الضغط واضافة المظلم كتجربة 😇 3- رسم على المخططات كانت للهندسة المدنية او للمركبات عند التحديد وضغط على ID الضغط مره وحده للصوره حرك الماوس الى المكان الرسم ثم اضغط من مفتاح الكيبورد F2 و اضغط كليك نقر الماوس ثم اضغط من مفتاح الكيبورد F2 =================================== الموضوع تجربة وتطبيق التجربة لموضوع سابق ActiveX 😇❤️ =================================== Activitx_InkPicture Control_TabStrip_Control_Form.part1.rar Activitx_InkPicture Control_TabStrip_Control_Form.part2.rar

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

شرح جميل وموفق اخي @ahmed draz 🤝🤗

السلام عليكم احبائي الاعزاء لكم كل تقدير واحترام لدي شيت اكسيل واريد عمل فورم لكل عمود واستنتاج بعض البيانات كلا على حدى واريد متميز واشرح له بعض الامور . ولكم جزيل الشكر والعرفان عينة للعمل.xlsx

تفضل اخي INVOICE.xlsm

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

اسف لم ادرك تعليقك حتى الان . اسف على التأخير الذي يمنع ان يكون أحد النماذج فى وضع popup انه يتم فتح اكثر من نموذج فى نفس الوقت حيث ان المهام مرتبطة ببعض واستكمال البيانات يكون عن طريق نسخ من نموذج اخر تلقائياً وفى بعض الاحيان يدوياً عن طريق نسخ ولصق ومرة أخرى أسف على التأخير فى الرد على الخبير Foksh هذا الأمر يعطى خطأ لأنه يتعارض مع بعض الاوامر وخصوصاً SetFocus

السلام عليكم ورحمة الله عند عملي على القاعدة المرفقة وجدت هذه الرسالة قل اعملوا فسيرى الله عملكم ورسوله والمؤمنون '............................................... إذا فتحت هذه القاعدة فأتقى الله وتعلم ولكن لاتسرق مجهود الأخرين '............................................... فإذا سرقت عملى وانسبته إليك فإنى خصيمك ليوم الدين '............................................... استفد واقتبس ولاتنسانا بالدعاء '............................................... أخوك فى الله / محمد هانى فأذكرك أخي (أنور حسن) أن لا تأتي يوم الفيامه وعليك دين لأحد أوخصوماً نسيتهم في الدنيا فوجدتهم عند الله فعليك أخي الكريم الأستئذان من الاستاذ / محمد هانى قبل العمل على هذه القاعدة ولأن القاعدة غير محمية قمت بتعديل الخطوط فقط لتظهر ازرار الانتقال . user pass admin 123 رابط خارجي للقاعدة لأن حجمها كبير ويخالف قواعد المنتدى https://www.raed.net/file?id=885026

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

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

جرب هدا Private Sub CommandButton3_Click() Dim x() As Variant Set f = Sheets(1): x = Array("ListBox1", "ListBox2") For i = 0 To UBound(x): Me.Controls(x(i)).Clear:: Next i Set d = CreateObject("Scripting.Dictionary") Set arr = f.Range("A2:E" & f.[A65000].End(xlUp).Row): a = arr.Value Dim tmp(): ReDim tmp(1 To UBound(a)) For i = LBound(a) To UBound(a) c = a(i, 3): Results = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5)) If OptionButton1 = True And c > Date And c <= (Date + 720) Or _ OptionButton2 = True And c > Date And c <= (Date + 90) Or _ OptionButton3 = True And c > Date And c <= (Date + 180) Or _ OptionButton4 = True And c > Date And c <= (Date + 360) Then n = n + 1: tmp(n) = i ReDim Preserve tmp(1 To n + 1) Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _ Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")"))) Me.ListBox1.RemoveItem n ElseIf c > 0 And c <= (Date) Then d(i) = Results End If Next n = d.Count If n > 0 And Me.OptionButton1 = True Or Me.OptionButton2 = True Or _ Me.OptionButton3 = True Or Me.OptionButton4 = True Then Dim cnt: cnt = Application.Transpose(d.items) ReDim Preserve cnt(1 To 5, 1 To n + 1) Me.ListBox2.List = Application.Transpose(cnt) Me.ListBox2.RemoveItem n End If For i = 0 To UBound(x) With Me.Controls(x(i)) .ColumnCount = 5: .ColumnWidths = "55;50;80;50;50" End With Next i End Sub

تفضلي استاذة @safaa salem5 . المرفق حسب طلبك . DDTest602-2.rar

لم أفهم المطلوب بشكل واضح 😬

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

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اضغط مرتين في اي خليه في عامود اسم الصنف في الفاتورة واكتب ما تريد البحث عنه في التيكست بوكس سوف يظهر لك الاصناف في الليست بوكس اضغط مرتي علي اي صنف تريده من الليست بوكس سوف يتم وضعه في اول خليه فارغه INVOICE.xlsm

بالفعل يافندم المدى مفتوح شكراااا لحضرتك

بارك الله فيك اخي مجدي علي المعلومة

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

لا هن اثنين كمبوبوكس واحد للسنه وواحد لاسم الموظف