سليم حاصبيا

اقترح هذا الملف من مواصفاته 1-عدم قدرة ادراج علامة اكبر من الحد الاقصى لكل مادة (تتلقى رسالة تنبيه) 2-يفوم بتجميع المجاميع لكل مادة (عملي نظري) 3-اذا بالخطأ ادخلت في خانة المجاميع اي شيء يتجاوز المعادلة (لان خانة المجميع تحتوي على معادلة) يفوم اكسل برفض هذا الشيء 4- القليل من Coditional format يغني عن الكثير (مراجعة لائحة الــ Coditional format) 5- يعطي النتيجة ناجح راسب 6-يفصل تلاميذ خالة القيد (ناجح راسب ) كل على صفحة مستقلة بضغطة على الزر الكود فيما بعد بسبب بطء النت الملف مرفق مع الكود للنتفيذ Awwal Zira3i_Super.xlsm

في الخلية الواحدة تستطيع ان تضع data validation واحدة اختر بين ان يكون عدد الــ X مرة واحدة او قائمة منسدلة تحتوي على X فقط قم بتعديل الماكرو الى هذا Option Explicit Private Sub Worksheet_Activate() data_validation End Sub Rem""""""""""""""""""""" Rem =====>Created By Salim Hasbaya on 4/7/2019 ' How to prevent the User from writing Duplicate ' In Given Range Sub data_validation() Dim k% Dim t With Sheets("تراكيب") Dim single_RG As Range Dim LR%: LR = .Cells(Rows.Count, 2).End(3).Row - 5 Dim my_rg As Range Dim sub_rg As Range Set my_rg = .Range("b9:q" & LR) For k = 2 To 17 Step 4 Set single_RG = .Range(Cells(9, k), Cells(LR, k + 3)) Select Case single_RG.Cells(1, 1).Address(0, 0) Case "B9": Set sub_rg = Range("B9:E" & LR) Case "F9": Set sub_rg = Range("F9:I" & LR) Case "J9": Set sub_rg = Range("J9:M" & LR) Case "N9": Set sub_rg = Range("N9:Q" & LR) End Select '====================== Select Case single_RG.Address(0, 0) '+++++++++++++++++++++++++++++ Case "B9:E" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($B9:$E9" & "," & "B" & 9 & ")<=1" .ErrorTitle = "انتباه" .ErrorMessage = "ا يمكن ادخال X الا مرة واحدة " End With '++++++++++++++++++++++++++++++ Case "F9:I" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($F9:$I9" & "," & "F" & 9 & ")<=1" .ErrorTitle = "انتباه" .ErrorMessage = "لا يمكن ادخال X الا مرة واحدة " End With '+++++++++++++++++++++++++++++ Case "J9:M" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($J9:$M9" & "," & "J" & 9 & ")<=1" .ErrorTitle = "انتباه" .ErrorMessage = "ا يمكن ادخال X الا مرة واحدة " End With '+++++++++++++++++++++++++++++ Case "N9:Q" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($N9:$Q9" & "," & "N" & 9 & ")<=1" .ErrorTitle = "انتباه" .ErrorMessage = "ا يمكن ادخال X الا مرة واحدة " End With End Select '========================== Next Set my_rg = Nothing: Set sub_rg = Nothing Set single_RG = Nothing End With End Sub

كنت قد ذكرت في المشاركة السابقة مواصفات الجدول الذي يمكن ان يطبق عليه الكود عندما يكون الجدول الذي تم رفعه بهذه المواصفات وتكون نتيجة ناجح او راسب موضوعة في اخر عامود من الجدول (ليس ناجحة أو راسبة بصيفة التأنيث لأن هذا يمكن عمله في النتيجة النهائية) يمكن ادراج ماكرو جديد يقوم بما يتوجب عمله قومي بتصميم الجدول بالضبط كما في الملف الذي رفعته (مجرد copy Paste للاسماء) من ملفك (الصفحة الاولى)الى الملف Awwal Zira3i في أول صفحة منه ابتداء من الصف رقم 10

للمرة الألف أذكر ان المعلومات في جداول الاكسل يجب ان تكون منسقة بطريقة معينة (اذا اردنا ان نعمل بواسطة الــ VBA ) لذلك سوف أقوم لاخر مرة بإعادة تنسيق جدول يفهمه الاكسل و تعيين ماكرو عليه و أعتذر عن أي عمل يخالف تعليمات الجداول والــ VBA من أهم الاشياء كي ينجح اي ماكرو هو معرفة تنسيق الجداول في اكسل 1- الجدول يجب ان يكون محاطاً بصفوف فارغة و أعمدة فارغة دون أي خلايا مدمجة أو ( عن يمينه حدود الصفحة و عن يساره عامود فارغ ) للغة العربية ( عن يساره حدود الصفحة و عن يمينه عامود فارغ ) للغة الاجنبية 2- تم عمل ذلك بتغيير تنسيق الجدول بهذه الطريقة (الصف التاسع فارغ و يبدأ الجدول من الصف العاشر) دون خلايا مدمجة داخل الجدول 3- الماكرو المطلوب (لم أقم بتمييز الناجح والرّاسب لان هذه البيانات غير موجودة) فقط الماكرو يعمل على الــ "مستجد" و "العمال" الماكرو Option Explicit Sub copy_and_filter() Application.ScreenUpdating = fasle Dim MRG As Range Dim sh As Worksheet Dim x, y%, MAX_ROW%, i% y = Sheets("الرصد").Cells(Rows.Count, 1).End(3).Row Set MRG = Sheets("الرصد").Range("a10:aw" & y) MAX_ROW = MRG.Rows.Count Dim arr_sh(1 To 4) arr_sh(1) = "ناجح مستجد": arr_sh(2) = "راسب مستجد" arr_sh(3) = "ناجح عمال": arr_sh(4) = "راسب عمال" Dim arr_CRIT(1 To 4) arr_CRIT(1) = "مستجد": arr_CRIT(2) = "مستجد" arr_CRIT(3) = "عمال": arr_CRIT(4) = "عمال" For Each sh In Sheets If Not (IsError(Application.Match(sh.Name, arr_sh, 0))) Then x = Application.Match(sh.Name, arr_sh, 0) sh.Range("t1") = arr_CRIT(x) End If Next For i = LBound(arr_sh) To UBound(arr_sh) Sheets(arr_sh(i)).Range("A11:AW1500").ClearContents MRG.AutoFilter 5, Sheets(arr_sh(i)).Range("t1") MRG.Offset(1).Resize(MAX_ROW - 1).SpecialCells(12).copy _ Sheets(arr_sh(i)).Range("a11") Sheets(arr_sh(i)).Range("t1") = vbNullString Next Erase arr_sh: Erase arr_CRIT: Set MRG = Nothing If Sheets("الرصد").AutoFilterMode = True Then Sheets("الرصد").ShowAllData End If Application.ScreenUpdating = True End Sub الملف مرفق Awwal Zira3i.xlsm

لم افهم ما معنى منتظم و من اين أحصل غلى هذه الكلمه في الملف

تم التعديل كما تريد (صفحة Salim من هذا الملف ) test_monthly1.xlsx

المعادلة لا تكتشف اي تنسيق ولا تعرف ولا تتعرف على لون الخلية او نوعية الخط فيها او قياسة او اي تنسيق اخر انها تنظر فقط الى محتوى خلية معينة او نطاق معين بغض النظر عن التنسيق Bold Font,Underline ,.interior Color الخ....) مثلاً معادلة IF تجيبنا عن سؤال (هل الخلية A5 تساوي 3 او أكبر من 10 او تحتوى على نص معين او فارغة) لماذا نطلب من المعادلة ما لا تقدر ان تقوم به كيف تقول للمعادلة اذا كان لون الخلية الفلانية احمر اعطني "OK" والا اعطني "No Red" مثلاً ربما هذا الكود يقوم بذلك Private Sub Worksheet_Change(ByVal Target As Range) Dim CEL As Range Application.EnableEvents = False If Not Intersect(Target, Range("L7:U13")) Is Nothing _ And Target.Count = 1 Then Range("B7:K13").ClearContents For Each CEL In Range("L7:U13") If CEL.Offset(, -10).Interior.ColorIndex = 6 Then CEL.Offset(, -10) = CEL End If Next End If Application.EnableEvents = True End Sub Auto Writing1.xls

لا يمكن لاي معادلة ان تعطي اي تنسيق للخلية او الخلايا (من لون أو خط ....الخ) على أمل ان تقوم المايكرو سوفت بعمل هكذا خاصية للمعادلات مرجعنا الاول والاخير هو الـ ـVBA

لا يمكن العمل حسب الجدول الذي وضعته لان، السنوات تخلتف من عامود الى اخر افترح عليك هذا الملف test_monthly.xlsx

استعمل هذه المعادلة للتنظيف من الفراغات الزائدة في الخلية F2 مثلاً واسحبها نزولاً =SUBSTITUTE(A2,32,"")

جرب هذا الكود Option Explicit Sub COLORIZE_CELLS() Dim CEL As Range With Range("B7:K13") .ClearContents .Interior.ColorIndex = xlNone End With For Each CEL In Range("L7:U13") If CEL <> vbNullString Then With CEL.Offset(, -10) .Value = CEL .Interior.ColorIndex = 6 End With End If Next End Sub الملف مرفق Auto Writing.xls

هات مثالاً عما تريد (الأفضل تضليل لعدم الدخول في مشاكل الــ Shapes ) و خذ ما يدهش العام

في هذا الملف نموذج عما تريد (فقط 10 اسماء للتدقيق في عمل الكود)يمكنك اضافة ما تريد من الصفوف مع تصحيح للماكرو Salim_User.xlsm

لم افهم ما تريد بالضبط ارفع ملفاً (يدوياً) بالنتيجة المتوقعة

ربما يكون هذا نموذج عما تريد VLkup.xlsx

الملف كبير جداً لكن هذا الماكرو يغنيك عن الحلقات التكرارية حتى 65000 واكثر فقط ادرج الارقام الصحيحة للــ ComboBoxes في الكود (انا لم أشاهد ComboBoxes رقم 133 مثلاً) Private Sub ComboBox3_Change() Dim Laste_row#: Laste_row = Sheets("data").Cells(Rows.Count, 1).End(3).Row Dim My_rgA As Range, r# Dim sarch_Rg As Range Set My_rgA = Range("a5:a" & Laste_row) Dim my_st my_st = Me.ComboBox3.Text Set sarch_Rg = My_rgA.Find(my_st) If sarch_Rg Is Nothing Then Exit Sub r = sarch_Rg.Row With Cells(r, "c") Me.TextBox1.Text = .Offset(0, -1) Me.TextBox133.Text = .Offset(0, 0) Me.TextBox132.Text = .Offset(0, 1) Me.TextBox111.Text = .Offset(0, 2) Me.TextBox2.Text = .Offset(0, 3) Me.TextBox3.Text = .Offset(0, 4) Me.TextBox4.Text = .Offset(0, 5) Me.TextBox7.Text = .Offset(0, 6) Me.TextBox130.Text = .Offset(0, 7) Me.TextBox131.Text = .Offset(0, 8) Me.TextBox22.Text = Offset(0, -2) End With End Sub

جرب هذا الماكرو Option Explicit Sub TALWEEN() Rem ====>> Created by Salim Hasbaya 6/7/2019 Application.ScreenUpdating = False Dim My_RGG As Range Dim My_RGH As Range Dim g%, h% Dim r%, r1, s_rg As Range Set My_RGG = Range("G3:G" & Cells(Rows.Count, 1).End(3).Row) Set My_RGH = Range("H3:H" & Cells(Rows.Count, 1).End(3).Row) Union(My_RGH, My_RGG).Interior.ColorIndex = xlNone For g = 1 To My_RGG.Rows.Count If My_RGG.Cells(g) = vbNullString Then GoTo Next_g Set s_rg = My_RGH.Find(My_RGG.Cells(g), lookat:=2) If s_rg Is Nothing Then GoTo Next_g End If My_RGG.Cells(g).Interior.ColorIndex = 6 r = s_rg.Row: r1 = r My_RGH.Cells(r - 2).Interior.ColorIndex = 6 Do Set s_rg = My_RGH.FindNext(s_rg) My_RGH.Cells(r - 2).Interior.ColorIndex = 6 r = s_rg.Row If r = r1 Then Exit Do Loop Next_g: Next Set My_RGG = Nothing Set My_RGH = Nothing Set s_rg = Nothing Application.ScreenUpdating = True End Sub الملف مرفق test (1)salim.xlsm

ممتاز لكن لعله كان هناك اكثر من مسافتين مثلاً 3 مسافات و من جهه اخرى نسيت الفاصلة في المعادلة =ISERROR(FIND(" ",A1))

جرب هذا الماكرو Option Explicit Sub Rename_Sheets() Dim sh As Worksheet '========================= 'choose here the name Dim My_name$: My_name = "Salim" '=========================== Dim t As Byte For Each sh In Sheets If sh.Name <> "Sheet1" Then sh.Name = My_name & "" & t t = t + 1 End If Next End Sub

1- في الورقة الاساسية قم بتسمية الجداول كما يلي (RG_1 (TABLE1) RG_2 (TABLE2 (RG_3 (TABLE3) RG_4 (TABLE4 2-قم بتسمية الشيت الاساسية "Main" (أفضل عدم تسمية الاوراق باللغة العربية لصعوبة نسخ الكود ولصقه حيث تظهر علامات و أحرف غير مفهومة) 3-نفذ هذا الماكرو Option Explicit Sub Copy_ranges() '======================================= Rem RG_1 (TABLE1):RG_2 (TABLE2) Rem RG_3 (TABLE3):RG_4 (TABLE4) '====================================== Dim k As Byte Dim i As Byte k = 1 For i = 1 To 4 Sheets(k).Range("A1").CurrentRegion.Clear Sheets("Main").Range("RG_" & i).Copy Sheets(k).Range("A1") k = k + 1 Next End Sub الملف مرفق COPY TABLES.xlsm

الصفحة Other_Calandre من هذا الملف auto Calander_NEW1.xlsx

الرد على السؤال الاول يجب منع وضع x في أكثر من خلية واحدة من الأعمدة 0،1،2،3 لكل موضوع قمت بوضع ملف نموذج صغير (صفحة salim) يستجيب لهذا التساؤل ممكن نسخ الكود والتعديل عليه بما يناسب الصفحة والنطاق التي يجب العمل عليها Option Explicit Private Sub Worksheet_Activate() data_validation End Sub Rem""""""""""""""""""""" Rem =====>Created By Salim Hasbaya on 4/7/2019 ' How to prevent the User from writing Duplicate ' In Given Range Sub data_validation() Dim k% Dim t With Sheets("Salim") Dim single_RG As Range Dim LR%: LR = .Cells(Rows.Count, 2).End(3).Row - 5 Dim my_rg As Range Dim sub_rg As Range Set my_rg = .Range("b9:q" & LR) For k = 2 To 17 Step 4 Set single_RG = .Range(Cells(9, k), Cells(LR, k + 3)) Select Case single_RG.Cells(1, 1).Address(0, 0) Case "B9": Set sub_rg = Range("b9:E" & LR) Case "F9": Set sub_rg = Range("E9:I" & LR) Case "J9": Set sub_rg = Range("J9:M" & LR) Case "N9": Set sub_rg = Range("N9:Q" & LR) End Select '====================== Select Case single_RG.Address(0, 0) '+++++++++++++++++++++++++++++ Case "B9:E" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($B9:$E9" & "," & "B" & 9 & ")<=1" End With '++++++++++++++++++++++++++++++ Case "F9:I" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($F9:$I9" & "," & "F" & 9 & ")<=1" End With '+++++++++++++++++++++++++++++ Case "J9:M" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($J9:$M9" & "," & "J" & 9 & ")<=1" End With '+++++++++++++++++++++++++++++ Case "N9:Q" & LR With single_RG.Validation .Delete .Add Type:=xlValidateCustom, _ Formula1:="=COUNTIF($N9:$Q9" & "," & "N" & 9 & ")<=1" End With End Select '========================== Next Set my_rg = Nothing: Set sub_rg = Nothing Set single_RG = Nothing End With End Sub بالنسبة للسؤال الثاني لم استطع فهم ماتريد (يرجى حذف عمليات دمج الخلايا) الملف النموذج مرفق Salim_Data_val.xlsm

اخي الكريم بدون ملف مرفوع لا تنتظر المساعدة من أحد فمن له الوقت لينشأ لك ملفاً بمواصفات لا يعرفها أحد

اذا كان ما فهمته صحيحاً فهذا المطلوب (الصفحة سليم من هذا الملف) auto Calander_NEW.xlsx

ربما يكون المطلوب (مع قليل من التّنسيق) auto Calander.xlsx