سليم حاصبيا

جرب هذا التعديل Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Cells.CountLarge > 1 Then GoTo 1 If Target.Row > 5 And Target.Column = 4 Then Dim lr As Long, x As Long, y As Variant y = Target.Value lr = Cells(Rows.Count, Target.Column).End(xlUp).Row x = Application.WorksheetFunction.CountIf(Range("D6:D" & lr), y) If y < 1 Or y > 10 Or Not IsNumeric(y) Then MsgBox "Wrong Entry", vbExclamation: Exit Sub If x > 50 Or y < 1 Or y > 10 Then _ MsgBox "The Number " & Target.Value & " Exceeds 50" & Chr(10) & _ "this number will be deleted", vbExclamation: Target = "" End If 1: Application.EnableEvents = True End Sub

ربما يفيدك هذا الملف استيراد بيانات.rar

ربما يكون الحل هنا percnet.rar

جرب هذا الكود Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim Lr As Long, My_name As String, x As Integer On Error Resume Next Lr = Sheets("Accounts").Range("c" & Rows.Count).End(xlUp).Row My_name = Sheets("Accounts").Cells(Lr, 3) x = Len(Sheets(My_name).Name) If x = 0 Then Sheets("Sample").Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = My_name End If On Error GoTo 0 End Sub الملف(نموذج )مرفق Create_sheet.rar

1-اختر اي خلية من العامود D 2-اضغط Alt+D+L تظهر لك نافذة والمعادلة المطلوبة من الخلية D6 لغاية الخلية D506

حرب هذا الملف Book1 Salim.rar

لا لزوم لتثبيت النطاق

بعد اذن اخي ابو البراء معادلة بسيطة في الخلية C3 و تسحب ياسراً =IF(B3<3,B3+1,1) اخي ياسر ما فيش لزوم لكل هذا التعب في وضع هكذا كود يكقي معادلة بسيطة =IF(B3<3,B3+1,1)

تم النعديل على المعادلات المصنف _Salim1.rar

جرب هذا المرفق المصنف _Salim.rar

الكود مقفل بكلمة سر

هذا لان الكود يحتوي على اللغة عربية في بعض سطوره انسخ هذين الكودين الى الملف من جديد Option Explicit Sub give_Alert() Dim My_Sh As Worksheet Dim R_G, Cel As Range Dim y As Boolean Dim r As Integer Application.EnableEvents = False Set My_Sh = Sheets("Salim _with_Macro") Set R_G = My_Sh.Range("d4:d53") R_G.Interior.ColorIndex = 0 For Each Cel In R_G If Cel <> "" Then y = Evaluate("=OR(""" & Cel & "" & """=AF4:AH11)") If Not y Then If r = 0 Then Cel.Interior.ColorIndex = 3 MsgBox "خطأ في القسم التابع لــــــ : " & Cel.Offset(, -2) & _ Chr(10) & "تم تلوين الاخطاء بالأحمر" _ , vbMsgBoxRight, "سليم يقول لك" End If r = r + 1 Cel.Interior.ColorIndex = 3 End If End If Next 1: Application.EnableEvents = True End Sub '========================================= Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Dim my_rg As Range Set my_rg = Range("d4:d53") If Not Intersect(Target, my_rg) Is Nothing Then give_Alert Target.Select End If Application.ScreenUpdating = True End Sub

مع انك لم ترفق ملف للعمل عليه اليك هذا النموذج الذي اتوقع ان يكون المطلوب بالنسبة الى الطلب الاول (اكتب جميع البيانات في الصفحة الاولى) و يتم البحث عنها في الصفحة الثاني حسب الاسم او الرمز roumouz.rar

تفضل الملف مع الكود انظر الى الصفحة Salim _with_Macro Demand Answer_Salim_4.rar

تم معاجة الامر انظر الى الصفحة Salim من هذا الملف Demand Answer_Salim_3.rar

و هكذا هو الامر (فقط اذا تم تسجيل قسم خاطئ تظهر الرسالة) اظر الى الصفحة Salim من هذا الملف Demand Answer_Salim_2.rar

تم التعديل على المعادلة Demand Answer_Salim_1.rar

بعد اذن اخي بن علية جرب هذا الشيئ Demand Answer_Salim.rar

للمحافظة على الالوان يمكن اسنعمال هذا الكود Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Range("My_Rg").Cells.Interior.ColorIndex = 39 For i = 1 To Range("My_Rg").Columns.Count If Range("My_Rg").Columns(i).Column Mod 2 = 0 Then Range("My_Rg").Columns(i).Interior.ColorIndex = 35 End If Next If Not Intersect(Target, Range("My_Rg")) Is Nothing And Target.Cells.Count = 1 Then Range(Target.Offset(0, -Target.Column + 1), Target).Interior.ColorIndex = 6 Range(Target.Offset(-Target.Row + 1, 0), Target).Interior.ColorIndex = 6 End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub

ارفع الملف نفسه و ليس صورة عنه

جرب هذا المثال الذي يمكنك البناء عليه كان يمكن وصع الماكرة مباشرة للملف عندك لكن في الصورة غير واضحة الاعمدة لاختيار لون اخر استبدل الرقم 6 في الماكر بالرقم الذي يعجبك(من 1 الى 52) تلوين نطاق.rar

حدد اي اعمدة تريد العمل عليها الكود المطلوب

بعد اذن اخي احمد هذا الكود من سطر واحد Sub translate_data() Range("a1:a" & Cells(Rows.Count, 1).End(3).Row). _ SpecialCells(2).Offset(, 1) = Format(Range("m1"), "mm-d") End Sub

حدد اي اعمدة تريد العمل عليها

استبدل في الكود كلمة xlPasteAll بالرقم 12