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

كثير من تصاميم HTML نتمنى ان تكون موجودة في الاكسس و ربما يصبح الحلم حقيقة عما قريب اضع بين يديكم فكرة ! فكرة جدول مبني بلغة HTML مع تلوين الاسطر عند المرور عليها آمل ان تنال على استحسانكم web.mdb

تفضل اخي بالتوفيق..... دوائر v3.xls

تفضل اخي Option Explicit Sub selectasheet() If Not SheetExists("" & Sheets("basic").Range("b2").Value) Then MsgBox "ورقة العمل غير موجودة!" Else Sheets("" & Sheets("basic").Range("b2").Value).Select End If End Sub Function SheetExists(SheetName As String) As Boolean SheetExists = False On Error GoTo NoSuchSheet If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True Exit Function End If NoSuchSheet: End Function المساعدة.xlsm

تفضل اخي Function circle1(dr As Range) Dim OvName As String OvName = "oval" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Line.Weight = False .Fill.ForeColor.RGB = RGB(255, 255, 0) End With End Function دوائر v2.xls

اخي هده مسالة اخرى ليس لها علاقة بالقوائم ولم نشتغل عليها من قبل على العموم تفضل اخي Dynamic Orders - Pivot_V11.xlsm

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

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

أهلا بك @Moosak أشكرك على ثناءك العطر.. لكن لا تبالغ 😊 أقول لك بصدق؛ إن الأفكار كثرت عليّ، وما أدري ما الذي أقدم منها فقلت أبدأ بالأيسر، ثم أتناقش معكم ماهو الأفضل والأنسب.. بعد أن أستعرض معكم مفاتيح البحث التي يوفرها الموقع. هذا صحيح! لأن الهدف هو جلب البيانات من الموقع وتكديسها في قاعدة البيانات، ثم النظر فيما بعد في كيفية استثمار تلك البيانات وفقاً لمتطلبات المطور..

اخي المفروض وضع الملفات بدون حماية محرر الاكواد او على الاقل ارفاق الباسوورد داخل المشاركة تفاديا لاهدار الوقت على العمود تم كسرها واتمام المطلوب تفضل جرب Dynamic Orders - Pivot_V10.xlsm Dynamic Orders - Pivot_V10.xlsm

هذه نسخة من التقويم الدراسي والمواعيد وتنظيم الأعمال والمشاريع بدون أكواد VBA وقريبا بإذن الله سأضع نسخة بالأكواد الهدف منها حفظ صورة من التقويم للاستفادة منها كخلفية لسطح المكتب في هذا الملف وضعت بيانات التقويم الدراسي في السعودية مع العلم أنه يمكن التعديل على هذه البيانات حسب حاجة المستخدم كتنظيم الأعمال ومراحل إدارة المشاريع وغيرها من الأعمال الأخرى ‏‏التقويم الدراسي والمواعيد - وتنظيم الأعمال والمشاريع.xlsx

Sub Test_A() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 5, 6) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_B() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 8, 9) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_C() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 11, 12) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '--------------------------------------------------------------------- If Arr(i, 4) = Ws.Range("D3").Value Then '----------------------------------------------------------------------- p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_D() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 14, 15) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '----------------------------------------- If Arr(i, 4) = Ws.Range("D3").Value Then '----------------------------------------- p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_E() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 17, 18) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_F() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 20, 21) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_G() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 23, 24) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub Test_H() ' ترحيل قائمة التلاميذ بناء على رقم الفصل '------------------------------------------------- Dim Ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long '----------------------------------------- Set Ws = Sheets("المواد منفصله") Set Sh = Sheets("data1") LR = Sh.Cells(Rows.Count, 2).End(xlUp).Row Ws.Range("C5:H34").ClearContents Arr = Sh.Range("A7:AB" & LR).Value Arr1 = Array(2, 26, 27) '======================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For i = 1 To UBound(Arr) '------------------------------------------ If Arr(i, 4) = Ws.Range("D3").Value Then '------------------------------------------ p = p + 1 For j = 0 To UBound(Arr1) Temp(p, j) = Arr(i, Arr1(j)) Next j End If Next i If p > 0 Then Ws.Range("C5").Resize(p, UBound(Temp, 2)).Value = Temp Application.ScreenUpdating = True End Sub Sub SS_Show() Subjects.Show End Sub استدعاء بيانات بطريقه الفورمه.xlsb استدعاء بيانات بطريقه الفورمه للعلامه باقشير

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخى circle.xlsm

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

ارفق نموذج مصغر لكي استطيع مساعدتك

تفضل جرب دوائر.xls

Try this modification Option Explicit Sub Draw_Circles() Const nMax As Integer = 30 Dim mx, ws As Worksheet, v As Shape, x As Integer, r As Long, c As Long, cnt As Long Call Remove_Circles x = ActiveWindow.Zoom Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("ty") ActiveWindow.Zoom = 100 mx = ws.Range("N2").Value If mx = 0 Or Not IsNumeric(mx) Then MsgBox "Enter Valid Number In Cell N2", vbExclamation: GoTo Skipper For c = 10 To 8 Step -1 For r = 4 To 14 Step 2 With ws.Cells(r, c) If .Value <> "" Then cnt = cnt + 1 Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 1, .Top + 1, .Width - 2, .Height - 2) v.Fill.Visible = msoFalse v.Line.ForeColor.SchemeColor = 10 v.Line.Weight = 1 If cnt = mx Then Exit For End If End With Next r If cnt = mx Then Exit For Next c cnt = 0 For c = 2 To 10 For r = 20 To 30 Step 2 With ws.Cells(r, c) If .Value <> "" Then cnt = cnt + 1 Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 1, .Top + 1, .Width - 2, .Height - 2) v.Fill.Visible = msoFalse v.Line.ForeColor.SchemeColor = 10 v.Line.Weight = 1 If cnt = nMax Then Exit For End If End With Next r If cnt = nMax Then Exit For Next c Skipper: ActiveWindow.Zoom = x Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub Sub Remove_Circles() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.AutoShapeType = msoShapeOval Then shp.Delete Next shp End Sub

اتفضل الحل فى الاستعلام ملاحظة الرقم 3 فى Space(3) هو عدد المسافات يمكن تغييره لما تريد Test.accdb

لوضع مسافات في الحقول ساتحدث عن طريقتين بدون اكواد ادخل على عرض التصميم للتقرير حدد الحقول المطلوبه ثم التبويب تنسيق ثم في خانة هامش ايمن ضع رقم 0.100سم او اكثر وفقا لما تريد بالزيادة او النقص الطريقة الثانية في حدث عند التحميل للتقرير ضع Me.tx.RightMargin = 100 tx هو اسم الحقل الرقم 100 ممكن زيلدته لزيادة المسافة وممكن انقاصه ايضل ممكن ايضا وضع الكود في حدث عن التنسيق ولكن سوف يظهر التأثير للكود فقط عند عرض التقرير في وضع معاينة قبل الطباعة قد تكون هناك طرق اسهل ولكن اخوك مجرد مزارع ولديه معلومات بسيطة في قواعد البيانات شايب

دخلت الموضوع ولدي الرغبة في تقديم يد العون صحيح انا مزارع ولكن لدي بعض المعرفة البسيطة بقواعد البيانات ولكني وجدت ان الطلب موجه الى مجموعة مختارة من الاعضاء وهذا الامر محير حيث اني عند انتسابي للموقع قبل اربعة ايام وجدت ان من شروط كتابة المشاركة عدة بنود منها 6. يمنع منعا باتا توجيه السؤال إلى شخص بعينه لان هذا قد يدفع الآخرين إلى عدم الإجابة، والهدف هو التفاعل من الجميع. على كل حال اتمنى من ادارة الموقع تحديث الشروط وحذف ما تم ايقاف العمل به لنكون على بينه ودمتم .,,, شايب

يفضل وضع الملف الذي به الكود على كل حال الكود لاختيار صورة من ملفات الكمبيوتر وعرضها في عنصر صورة وإضافتها في قائمة صور بهدف عرض صورة لكل موظف مثلا بالتوفيق للجميع

أفكار جميلة ورائعة بارك الله فيكم جميعا أحبتي ونظرا لأني أهوى اختصار الأكواد والمعادلات يمكنني تعديل المعادلة إلى في A2 =MID(SUBSTITUTE(A$1," ",""),ROW(A1),1) بالتوفيق

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

في زر الامر ضع الكود Dim x As String x = Me.EmpName.Column(1) & ".rtf" DoCmd.OpenReport "Hr_Letter_Rep", acViewPreview, , "[Empcoode]=" & Me.Empcoode DoCmd.OutputTo acOutputReport, "Hr_Letter_Rep", _ acFormatRTF, "d:\" & x, True وبالامكان تغيير مكان الحفظ من الدريف d الى اي قرص HR_Letter.rar

=MID(SUBSTITUTE(A$1;" ";"");ROWS(A$2:A2);1)

هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها فجزى الله كل من كانت له بصمه في هذا العمل كنترول محمدي9.xlsb كلمة سر فتح البرنامج 111

احضار بيانات الطلاب من موقع الوزاره احضار بيانات الطلاب من النت.xlsb

مجموعه اخرى يكتبها الله في كفه حسناتهم رقم الدخول 2020 https://www.mediafire.com/file/e4vla3z22dtc11c/_+الرابـع++متميز.xlsb/file تم ارفاق الملف في المنتدي _ الرابـع متميز.xlsb

حمد لله على السلام استاذنا حفظكم الله ورعاكم وجزاكم الله خيراً

اظهاز طلاب الدور التاني 'هذا الكود للمحترم النابغه ياسر خليل ' الهدف من الكود هو استدعاء بشرط من خارج الكود 'تم هذا الكود في 15/2/2017 '==*==*==*==*==*==*==*==*==*==* Sub كشوف_كنترول_ثان() ActiveSheet.Unprotect Dim Arr As Variant Dim Arry As Variant Dim Lr As Long Dim i As Long Dim J As Long Dim Main As Worksheet Dim sh As Worksheet Dim NUM1 As Integer Dim NUM2 As Integer Dim Trgt1 As String Dim Trgt2 As String 'رقم عمود البحث NUM1 = 133 'عمود الشرط الاول NUM2 = 144 'عمود الشرط الثاني '=*=*=*=*=*=*=*=*=*=*=*=* Set Main = Sheets("رصد الترم الثانى") Set sh = Sheets("كشوف الترم الأول") 'خليه البحث Trgt1 = sh.Range("D1") & "*" 'الشرط الاول Trgt2 = sh.Range("E1").Value 'الشرط الثاني On Error Resume Next 'مدى المسح في صفحه الهدف '=========================================================== sh.Range("A7:AM1000").ClearContents '=========================================================== Lr = Main.Cells(Rows.Count, 1).End(xlUp).Row '=========================================================== Arr = Main.Range("A7:GB" & Lr).Value '=========================================================== 'مدى صفحه الهدف Arry = sh.Range("A7:AM1000") J = 1 For i = LBound(Arr, 1) To UBound(Arr, 1) 'رقم عمود البحث 'If arr(i, NUM1) Like Trgt1 Then 'If arr(i, NUM1) Like Trgt1 & "*" Then If Arr(i, NUM1) Like Trgt1 & "*" And Arr(i, NUM2) Like Trgt2 Then '=========================================================== Arry(J, 1) = J 'العمود الاول بعد المسلسل Arry(J, 2) = Arr(i, 2) Arry(J, 3) = Arr(i, 3) Arry(J, 4) = Arr(i, 140) Arry(J, 5) = Arr(i, 142) Arry(J, 6) = Arr(i, 143) Arry(J, 7) = Arr(i, 14) Arry(J, 8) = Arr(i, 15) Arry(J, 9) = Arr(i, 25) Arry(J, 10) = Arr(i, 26) Arry(J, 11) = Arr(i, 36) Arry(J, 12) = Arr(i, 37) Arry(J, 13) = Arr(i, 47) Arry(J, 14) = Arr(i, 48) Arry(J, 15) = Arr(i, 60) Arry(J, 16) = Arr(i, 61) Arry(J, 17) = Arr(i, 68) Arry(J, 18) = Arr(i, 69) Arry(J, 19) = Arr(i, 75) Arry(J, 20) = Arr(i, 76) Arry(J, 21) = Arr(i, 82) Arry(J, 22) = Arr(i, 83) Arry(J, 23) = Arr(i, 89) Arry(J, 24) = Arr(i, 90) Arry(J, 25) = Arr(i, 96) Arry(J, 26) = Arr(i, 97) Arry(J, 27) = Arr(i, 98) Arry(J, 28) = Arr(i, 99) Arry(J, 29) = Arr(i, 99) Arry(J, 30) = Arr(i, 109) Arry(J, 31) = Arr(i, 110) Arry(J, 32) = Arr(i, 131) Arry(J, 33) = Arr(i, 132) Arry(J, 34) = Arr(i, 133) Arry(J, 35) = Arr(i, 134) '=========================================================== J = J + 1 End If Next i With sh '=========================================================== 'خليه بدايه اللصق .Range("B7").Resize(J - 1, UBound(Arry, 2)).Value = Arry 'مدى المسح في صفحة الهدف .Range("A7:AM" & Rows.Count).Borders.Value = 0 '=========================================================== 'سطر لاضافة التسطير .Range("B7:AM" & .Cells(Rows.Count, 4).End(xlUp).Row).Borders.Value = 1 End With Erase Arr Erase Arry ActiveSheet.Protect End Sub

مساعد اخر للمحترم ظفر الله عسكر يحفطه الرحمن الرحيم مساعد الجداول لظفر الله .xlsx

Insert Module1 and paste the following code Option Explicit Private Sub ColorBySubject() Const STARTROW As Long = 8, STARTCOL As Long = 5, COLSNUM As Long = 4 Dim x, aCols, wsMarks As Worksheet, wsColors As Worksheet, rng As Range, sMarks As String, sQuote As String, sCell As String, n As Long, m As Long, ii As Long Application.ScreenUpdating = False With ThisWorkbook Set wsMarks = .Worksheets(1) Set wsColors = .Worksheets(2) End With Set rng = wsColors.Range("S8:S15") x = Application.Match(wsColors.Range("E3").Value, rng, 0) If Not IsError(x) Then sMarks = wsMarks.Name sQuote = WorksheetFunction.Rept(Chr(34), 2) n = wsMarks.Cells(Rows.Count, "C").End(xlUp).Row - 3 aCols = Array(5, 8, 11, 14, 17, 20, 23, 26) For m = 1 To 3 sCell = ColumnToLetter(aCols(x - 1) + m - 1) & "4" With wsColors If m <> 3 Then For ii = 4 To 1 Step -1 With .Cells(STARTROW, m * COLSNUM - ii + STARTCOL).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=" & ii & ",""0""," & sQuote & "))" End With Next ii Else With .Cells(STARTROW, 13).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & ">=3.5,""0""," & sQuote & "))" .Offset(, 1).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">=2.5," & sMarks & "!" & sCell & "<3.5),""0""," & sQuote & "))" .Offset(, 2).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">1," & sMarks & "!" & sCell & "<2.5),""0""," & sQuote & "))" .Offset(, 3).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=1,""0""," & sQuote & "))" End With End If End With Next m End If Application.ScreenUpdating = True End Sub Function ColumnToLetter(ByVal columnNumber As Long) As String If columnNumber < 1 Then Exit Function ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A"))) End Function Then in worksheet module (Colors) [The worksheet that has the data validation list], paste the following code Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$E$3" Then Application.Run "Module1.ColorBySubject" End If End Sub

تفضل اخوي مثالك بعد التعديل عليه PARPAIN_Email-01.zip