سليم حاصبيا

ممكن ذلك

ربما تم تعريف lngNum على انه رقم في بداية الكود بجب تعريفه بهذا الشكل Dim lngNum فقط

لا اعلم اذا كان المطلوب Salim مثال.rar

ارفغ ملفاً كمثال عما تريد

تم معالجة الامر (حتى في حال وجود اكثر من موظف تنطبق عليه الشروط) درجات Salim.rar

جرب هذا الملف SHEET_Salim.rar

ربما كان المطلوب صفحة Data salim02.rar

المعادلات لا تقوم بتنسيق الخلايا من الوان وخط ... الخ (فقط الكود او التسيق الشرطي) ربما تستطبع الاعتماد على هذا النموذج Tarikh.rar

بدون اكواد ربما يكون المطلوب (انظر الى الورقة Salim) تم حمابة المعادلات لعدم العبث بها عن طربق الخطأ salim01.rar

انسخ هذه المعادلة الى E2 ,واسحب نزولاً =IF(N($C2)=0,"",CHOOSE(($C2>36000)+1,700000,750000))

حرب هذا الملف تستطيع ان تتعامل طبيعياً مع الورقة حتى و لو كان اليوزر ظاهراً الكود Option Explicit Private Sub Command1_Click() Application.ScreenUpdating = False Dim arr(), str$ Dim k%, x%, My_Num, lr%, i%, t% Dim sh As Worksheet: Set sh = Sheets("add") My_Num = sh.[j6] If Not IsNumeric(My_Num) Or My_Num < 1 _ Or My_Num = vbNullString Then My_Num = 10 Else My_Num = Int(My_Num) End If k = 1 lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("e2:f" & lr).ClearContents For i = 6 To lr Step My_Num x = InStr(Me.TextBox2, " ") str = Left(Me.TextBox2, x - 1) str = str & k If lr - i < My_Num Then t = lr - i + 1 sh.Range("f" & i).Resize(t) = Me.TextBox3 sh.Range("e" & i).Resize(t) = str: Exit For End If sh.Range("f" & i).Resize(My_Num) = Me.TextBox3 sh.Range("e" & i).Resize(My_Num - t) = str k = k + 1 Next Application.ScreenUpdating = True 'Unload Me 'تستطيع تشغيل هذا السطر اذا اردت ان يختفي الفورم End Sub الملف اضافه1 Salim.rar

جرب هذا الكود /// يعمل من الخلية A1 حتى اخر خلية ضمن a1] .CurrentRegion] Option Explicit Sub lockCells() Application.EnableEvents = False Dim X As Range With ActiveSheet .Unprotect .Cells.Locked = False If .AutoFilterMode = False Then .[a1].CurrentRegion.AutoFilter Set X = .[a1].CurrentRegion.Cells.SpecialCells(-4123, 23) With X .Locked = True .FormulaHidden = True End With ActiveSheet.Protect AllowFormattingCells:=True, AllowFiltering:=True, AllowSorting:= _ True, Contents:=True, Scenarios:=True, userinterfaceonly:=True End With Application.EnableEvents = True End Sub الملف مرفق filter_ME.rar

جرب هذا الملف Aziz salim.rar

هذه المعادلة البسيطة =MAX(A:A)

جرب هذا الكود Option Explicit Sub Numeration_by_seletion() Dim sh As Worksheet Dim My_Str$ Dim lr%, k%, x% k = 1 Set sh = Sheets("Data") With sh My_Str = .[a1] lr = .Cells(Rows.Count, 4).End(3).Row .Range("b2:b" & lr).ClearContents If My_Str = vbNullString Then MsgBox "the cell $A$1 is Empty ": Exit Sub If Not (Application.CountIf(.Range("d2:d" & lr), My_Str)) Then _ MsgBox "The cell $A$1 with value : " & My_Str & Chr(10) & _ " Not exists in the range": Exit Sub For x = 2 To lr With .Range("d" & x): If .Value = My_Str Then _ .Offset(0, -2) = k: k = k + 1 End With Next End With End Sub

ربما كان المطلوب Extract_num_Or_letters.rar

لا اعرف اذا كان هذا المطلوب فعلاً انظر الى الصفحة Salim من هذا الملف Choose Salim.rar

Option Explicit Sub New_Numeration1() Dim sh As Worksheet Dim k%, lr% Set sh = Sheets("Data") lr = sh.Cells(Rows.Count, 4).End(3).Row sh.Range("b2:b" & lr).ClearContents k = 2 With sh Do Until k > lr If Range("d" & k) <> "" Then _ Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k)) k = k + 1 Loop End With End Sub

ما تحكي كده من الصبح Option Explicit Sub New_Numeration() Dim sh As Worksheet Dim k% Set sh = Sheets("Data") k = 2 With sh Do Until Range("d" & k) = "" Range("b" & k) = Application.CountIf(.Range("d2" & ":d" & k), .Range("d" & k)) k = k + 1 Loop End With End Sub

جرب هذه المعادلة في الخلية B2 ,و اسجب نزولاُ لو كان المطلوب نحولها الى كود =INT((ROWS($A$1:A1)-1)/8)+1

الماكرو المطلوب Sub numeraton2() Dim sh As Worksheet Dim arr() Dim lr%, k%, i% Set sh = Sheets("Data") k = 1 '========================= With sh lr = .Cells(Rows.Count, 4).End(3).Row .Range("b2:b" & lr).ClearContents For i = 2 To lr If Application.CountIf(.Range("d2" & ":d" & i), .Range("d" & i)) = 1 Then ReDim Preserve arr(1 To k): arr(k) = .Range("d" & i): k = k + 1 End If Next k = 1 For i = 2 To lr Step UBound(arr) .Range("b" & i) = k: k = k + 1 Next End With Erase arr End Sub

جرب هذا الكود (استبدل اسم الورقة الى Data لسهولة التعامل مع اللفة الاحنبية) Option Explicit Option Base 1 Sub Numeration() Dim sh As Worksheet Dim arr() Dim lr%, k%, x% k = 1 Set sh = Sheets("Data") With sh lr = .Cells(Rows.Count, 4).End(3).Row .Range("c2:c" & lr).ClearContents For x = 2 To lr If Application.CountIf(.Range("d2" & ":d" & x), .Range("d" & x)) = 1 Then ReDim Preserve arr(1 To k): arr(k) = .Range("d" & x): k = k + 1 End If Next For k = 2 To lr .Range("c" & k) = Application.Match(.Range("d" & k), arr, 0) Next End With Erase arr End Sub الملف مرفق 2مثال سليم.rar

لا حاجة للكود تكفي معادلة واحدة توضع في الخلية E2 وتسحب نزولاً (هذا اذا كنت قد فهمت السؤال جيداً) في حال الحطأ ارفع ملفاً يحتوي نموذجاً عن النتائج المتوقعة =IFERROR(IF(ROWS($E$1:E2)>COUNTA(D:D),"",IF(COUNTIF($D$2:D2,D2)=1,MAX($E$1:E1)+1,INDEX($E$1:$E1,MATCH(D2,$D$1:$D1,0)))),"") الملف مرفق مثال سليم.rar

اذا اردتها بدون عامود مساعد انظر الى المعادلة في الخلية P13 و تزولاً TEST2 salim.rar

ربما يكون الحل هتا TEST1 salim.rar