بحث مخصص من جوجل فى أوفيسنا
![]()
Custom Search
|
نجوم المشاركات
Popular Content
Showing content with the highest reputation on 06/05/23 in مشاركات
-
كثير من تصاميم HTML نتمنى ان تكون موجودة في الاكسس و ربما يصبح الحلم حقيقة عما قريب اضع بين يديكم فكرة ! فكرة جدول مبني بلغة HTML مع تلوين الاسطر عند المرور عليها آمل ان تنال على استحسانكم web.mdb3 points
-
3 points
-
تفضل اخي 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 المساعدة.xlsm2 points
-
تفضل اخي 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.xls2 points
-
اخي هده مسالة اخرى ليس لها علاقة بالقوائم ولم نشتغل عليها من قبل على العموم تفضل اخي Dynamic Orders - Pivot_V11.xlsm2 points
-
طريقة الاستعمال يوجد صفحه اسمها الخطة اكتب فيها اسماء المواد المطلوبه ثم اكمل تسجيل نصاب كل مدرس من واقع الخطه المدرسيه في نفس الصفحه الخطة انتقل الي صفحه الفصول ستجدها منظمه حدد البانات فيها ثم انسخها انتقل الي برنامج الجدول المدرسي والصق المنسوخ في البرنامج طريقه من طرق الادخال سهله ودقيقه يحفظ ربنا ويبارك للعلامه عبد الله باقشير وكل من في المنتدى المحترم2 points
-
2 points
-
أهلا بك @Moosak أشكرك على ثناءك العطر.. لكن لا تبالغ 😊 أقول لك بصدق؛ إن الأفكار كثرت عليّ، وما أدري ما الذي أقدم منها فقلت أبدأ بالأيسر، ثم أتناقش معكم ماهو الأفضل والأنسب.. بعد أن أستعرض معكم مفاتيح البحث التي يوفرها الموقع. هذا صحيح! لأن الهدف هو جلب البيانات من الموقع وتكديسها في قاعدة البيانات، ثم النظر فيما بعد في كيفية استثمار تلك البيانات وفقاً لمتطلبات المطور..2 points
-
اخي المفروض وضع الملفات بدون حماية محرر الاكواد او على الاقل ارفاق الباسوورد داخل المشاركة تفاديا لاهدار الوقت على العمود تم كسرها واتمام المطلوب تفضل جرب Dynamic Orders - Pivot_V10.xlsm Dynamic Orders - Pivot_V10.xlsm2 points
-
بسم الله الرحمن الرحيم الحمد لله و الشكر له الذي أنعم علينا بنعم لاتعد و لاتحصى ومن هذه النعم وجود هذا المنتدى القيم وانعم علينا بوجود هذه الزمرة المتميزة في المنتدى التي تعمل وتقدم الخير ولاتنتظر إلا الجزاء من الله عز وجل كافأهم الله بكل خير وأنعم علينا أيضا بساحر الاكسيل ومهندسه العالم العلامة والبحر الفهامة بمشيئة الله عبد الله باقشير وهو من أحب الناس إلى قلب اخيه الأستاذ / محمدي عبد السميع عبد الغني حفظه الله ورعاه وحفظ الجميع من كل سوء ......... آمين يارب العالمين وبعد هذا ملف اكثر من رائع خاص بادخال البيانات بسهوله وسلاسه الي برنامج ASC وان شاء الله شأشرح الطريقه في وقت لاحق مساعد ادخال جدول للعلامه عبد الله باقشير.xls1 point
-
هذه نسخة من التقويم الدراسي والمواعيد وتنظيم الأعمال والمشاريع بدون أكواد VBA وقريبا بإذن الله سأضع نسخة بالأكواد الهدف منها حفظ صورة من التقويم للاستفادة منها كخلفية لسطح المكتب في هذا الملف وضعت بيانات التقويم الدراسي في السعودية مع العلم أنه يمكن التعديل على هذه البيانات حسب حاجة المستخدم كتنظيم الأعمال ومراحل إدارة المشاريع وغيرها من الأعمال الأخرى التقويم الدراسي والمواعيد - وتنظيم الأعمال والمشاريع.xlsx1 point
-
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 استدعاء بيانات بطريقه الفورمه للعلامه باقشير1 point
-
السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخى circle.xlsm1 point
-
1 point
-
1 point
-
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 Sub1 point
-
اتفضل الحل فى الاستعلام ملاحظة الرقم 3 فى Space(3) هو عدد المسافات يمكن تغييره لما تريد Test.accdb1 point
-
لوضع مسافات في الحقول ساتحدث عن طريقتين بدون اكواد ادخل على عرض التصميم للتقرير حدد الحقول المطلوبه ثم التبويب تنسيق ثم في خانة هامش ايمن ضع رقم 0.100سم او اكثر وفقا لما تريد بالزيادة او النقص الطريقة الثانية في حدث عند التحميل للتقرير ضع Me.tx.RightMargin = 100 tx هو اسم الحقل الرقم 100 ممكن زيلدته لزيادة المسافة وممكن انقاصه ايضل ممكن ايضا وضع الكود في حدث عن التنسيق ولكن سوف يظهر التأثير للكود فقط عند عرض التقرير في وضع معاينة قبل الطباعة قد تكون هناك طرق اسهل ولكن اخوك مجرد مزارع ولديه معلومات بسيطة في قواعد البيانات شايب1 point
-
دخلت الموضوع ولدي الرغبة في تقديم يد العون صحيح انا مزارع ولكن لدي بعض المعرفة البسيطة بقواعد البيانات ولكني وجدت ان الطلب موجه الى مجموعة مختارة من الاعضاء وهذا الامر محير حيث اني عند انتسابي للموقع قبل اربعة ايام وجدت ان من شروط كتابة المشاركة عدة بنود منها 6. يمنع منعا باتا توجيه السؤال إلى شخص بعينه لان هذا قد يدفع الآخرين إلى عدم الإجابة، والهدف هو التفاعل من الجميع. على كل حال اتمنى من ادارة الموقع تحديث الشروط وحذف ما تم ايقاف العمل به لنكون على بينه ودمتم .,,, شايب1 point
-
يفضل وضع الملف الذي به الكود على كل حال الكود لاختيار صورة من ملفات الكمبيوتر وعرضها في عنصر صورة وإضافتها في قائمة صور بهدف عرض صورة لكل موظف مثلا بالتوفيق للجميع1 point
-
أفكار جميلة ورائعة بارك الله فيكم جميعا أحبتي ونظرا لأني أهوى اختصار الأكواد والمعادلات يمكنني تعديل المعادلة إلى في A2 =MID(SUBSTITUTE(A$1," ",""),ROW(A1),1) بالتوفيق1 point
-
السلام عليكم أهلا بكم... هذه مشاركة بسيط ضمن هذا العنوان العريض.. نموذج يقوم بالبحث في المنتى ويعيد البيانات التالية (رقم المشاركة، عنوان المشاركة، موضوع المشاركة) ويخزنها في جدول البيانات، مع ربط عنوان المشاركة بالموقع.. البحث في عناوين المشاركات فقط.. إذا كان مجال البحث يتضمن صفحات متعددة فإنه يعيد بيانات الصفحة الأولى في هذه المرحلة... سوف أناقش إن شاء الله،، فيما بعد مفاتيح البحث التي يقدمها الموقع وكيفية الاستفادة منها.. إليكم المشاركة.. SearchInOfficena.accdb1 point
-
في زر الامر ضع الكود 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.rar1 point
-
1 point
-
هذه الأكواد و ليس برنامج متكامل ينقص البرنامج بعض اللمسات ويكون جاهزا الأكواد والأعمال لأصحابها وليس لي الفضل الا في تجميعها وتنسيقها فجزى الله كل من كانت له بصمه في هذا العمل كنترول محمدي9.xlsb كلمة سر فتح البرنامج 1111 point
-
1 point
-
مجموعه اخرى يكتبها الله في كفه حسناتهم رقم الدخول 2020 https://www.mediafire.com/file/e4vla3z22dtc11c/_+الرابـع++متميز.xlsb/file تم ارفاق الملف في المنتدي _ الرابـع متميز.xlsb1 point
-
حمد لله على السلام استاذنا حفظكم الله ورعاكم وجزاكم الله خيراً1 point
-
اظهاز طلاب الدور التاني 'هذا الكود للمحترم النابغه ياسر خليل ' الهدف من الكود هو استدعاء بشرط من خارج الكود 'تم هذا الكود في 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 Sub1 point
-
مساعد اخر للمحترم ظفر الله عسكر يحفطه الرحمن الرحيم مساعد الجداول لظفر الله .xlsx1 point
-
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 Sub1 point
-
1 point