سليم حاصبيا

قلت لك المعادلة معادلة صفيف وليس معادلة عادية (يلزمها Ctrl+shift+Enter) وليس Enter وحدها 1- انسخ المعادلة 2- اضغط باستمرار على زري Ctrl+shift 3 انقر على زر Enter اذا لم تعمل استبدل الفاصلة " ," بفاصلة منقوطة "; " )حسب اعدادات الجهاز عندك") لتبدو المعادلة بهذا الشكل =SUM(1/COUNTIF($A$2:$A$10;$A$2:$A$10))

(Ctrl+Shift+Enter) جرب هذا المعادلة =SUM(1/COUNTIF($A$2:$A$10,$A$2:$A$10))

الملف الذي رفعته لا يحتوي على اي كود انه بصيغة xlsx و لكن اليك الكود المناسب لهذا الأمر Option Explicit Sub ADD_SH_with_Hyper() 'code to add Sheets One Time WITH HYPERLINKS 'Crated By Salim Hasbaya On 7/10/2019 Dim Rg As Range Dim sh As Worksheet Dim LA%, i% Set sh = Sheets("SALIM") LA = sh.Cells(Rows.Count, 1).End(3).Row For Each Rg In sh.Range("A2:A" & LA) If Rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Rg.Value With ActiveSheet .Hyperlinks.Add Anchor:=.Range("c2"), Address:="", SubAddress:= _ "SALIM!A1", TextToDisplay:="Goto SALIM" .Columns(3).AutoFit End With End If End If Next Rg With Sheets("SALIM") .Hyperlinks.Delete For i = 2 To LA .Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:= _ .Range("A" & i) & "!A1", TextToDisplay:=.Range("A" & i).Value Next .Select End With End Sub الملف مرفق create_sh_with_hyperxlsx.xlsm

بالنسبة للــ CommandButton1_Click انا أفضل هذا الكود البسيط ولا لزوم لللتفتيش عن قيمته في كل الصفوف حيث ان دالة Match تعطينا اياه رأساً Private Sub CommandButton1_Click() Dim lr, i With Sheets("11") If ComboBox2 = "" Then Exit Sub lr = Application.Match(ComboBox2, .Columns(6), 0) For i = 1 To 4 Me.Controls("TextBox" & i) = _ .Cells(lr, "b").Offset(, i - 1) Next End With End Sub

جرب هذا الملف Book3_salim.xlsm

زيادة في اثراء الموضوع و بعد اذن اخي الحبيب علي هذا الملف ADD_SHEET.xlsm

تم التعديل يمكن الفلترة بالفصل والتخصص في نفس الوقت first_20 New.xlsm

في المرة المقبلة ارفع ملف للمعالجة جرب هذا الملف super rand.xlsx

ربما كان المطلوب Takssim.xlsx

تم التعديل على الماكروات كما يلزم (فقط اضغط على الزر بحث) Option Explicit Sub cop() Dim R1%, R2% R1 = Range("b8").CurrentRegion.Rows.Count R2 = Range("A10000").CurrentRegion.Rows.Count If R1 > R2 Then Range("A10000").CurrentRegion.ClearContents Range("B8").CurrentRegion.Copy Range("A10000") End If End Sub Private Sub Worksheet_Activate() FIL_data_val End Sub '++++++++++++++++++++++++++++++++++++++ Sub new_filter() cop Dim i As Byte, k As Byte Dim LX%, RO%, x Dim arr() Dim st1, st2 Dim Rg As Range: Set Rg = Targt.Range("C5:F5") Dim Frg As Range: Set Frg = Range("A10000").CurrentRegion RO = Frg.Rows.Count k = 4: x = 0 On Error Resume Next If Frg.AutoFilterMode Then Frg.ShowAllData: Frg.AutoFilter End If On Error GoTo 0 Targt.Range("b8").CurrentRegion.ClearContents For i = 1 To k If Rg.Cells(i) <> "" Then x = x + 1 ReDim Preserve arr(1 To x): arr(x) = Rg.Cells(i) & "*" & i + 1 End If Next i On Error Resume Next LX = LBound(arr) If LX = 0 Then Frg.Copy Targt.Range("B8") Frg.ShowAllData: Frg.AutoFilter GoTo End_Me End If On Error GoTo 0 For i = LBound(arr) To UBound(arr) st1 = Val(Split(arr(i), "*")(1)) st2 = Split(arr(i), "*")(0) Frg.AutoFilter Field:=st1, Criteria1:=st2 Next i Frg.SpecialCells(2, 23).Copy Targt.Range("B8") On Error Resume Next End_Me: If Frg.AutoFilterMode Then Frg.ShowAllData: Frg.AutoFilter End If End Sub '++++++++++++++++++++++++++++++++++++ Sub FIL_data_val() Dim RGs As Range Dim Coll As Object Dim Rs%, Rt%, i%, k% Set RGs = Range("a10000").CurrentRegion Rs = RGs.Rows.Count Set Coll = CreateObject("System.Collections.Arraylist") For i = 2 To 5 With RGs.Columns(i).Offset(1).Resize(Rs - 1) For k = 1 To Rs - 1 If Not Coll.contains(.Cells(k).Value) Then Coll.Add .Cells(k).Value End If Next k End With Coll.Sort With Targt.Cells(5, "c").Offset(, i - 2).Validation .Delete .Add 3, Formula1:=Join(Coll.toArray, ",") End With Coll.Clear Next i End Sub 15_20.xlsm

للمرة الالف اكررر لا يمكن ادراج خلايا مدمجة في اي جدول من جداول الاكسل تم حذف الادماج و وضع ماكرو في الملف المرفق كما تم تغيير اسم الاوراق الى اللغة الاجنبية لحسن نسخ الكود بدون ظهور احرف غريبة و غير مفهومة الكود Option Explicit Private Sub Worksheet_Activate() GetUnique End Sub '++++++++++++++++++++++++++++++++++++++++++++ Sub GetUnique() 'VBA to extract unique items (with the dictionary) Dim L As Worksheet Dim T As Worksheet Dim TLr%, i% Dim LRG As Range Dim obj As Object Set L = Sheets("list"): Set T = Sheets("total") TLr = T.Cells(Rows.Count, 5).End(3).Row Set LRG = T.Range("e2:e" & TLr) Set obj = CreateObject("scripting.dictionary") With obj For i = 2 To TLr - 1 .Item(T.Cells(i, 5).Value) = "" Next With Sheets("list").Range("D2").Validation .Delete .Add 3, Formula1:=Join(obj.keys, ",") End With End With Set obj = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++++ Sub filter_me() Dim L As Worksheet Dim T As Worksheet Dim TLr%, i%, Max_row% Dim LRG As Range Set L = Sheets("list"): Set T = Sheets("total") L.Range("B4").Resize(1000, 4).ClearContents TLr = T.Cells(Rows.Count, 5).End(3).Row Set LRG = T.Range("A1:J" & TLr) On Error Resume Next If T.FilterMode Then T.ShowAllData: LRG.AutoFilter End If On Error GoTo 0 LRG.AutoFilter 5, L.Range("D2") Max_row = LRG.Rows.Count With LRG.Offset(1).Resize(Max_row - 1).SpecialCells(2, 23) .Columns(1).Copy: L.Range("B4").PasteSpecial xlPasteValues .Columns(9).Copy: L.Range("C4").PasteSpecial xlPasteValues End With On Error Resume Next If T.FilterMode Then T.ShowAllData: LRG.AutoFilter End If On Error GoTo 0 End Sub الملف first_20.xlsm

يا أخي القائمة المنسدلة تتجدد كلما أضفت اسماً الى اللائحة

تم معالجة الامر فقط اختر الاسم المناسب من الخلية الصفراء والكود يقوم بعمله Record 1_1.xlsm

جيد استاذ وجيه نفس الماكرو بدون هذا الكم المتكرر من IF و ELSE Sub TEST() Dim RESULT$ For i = 6 To 30 Select Case Cells(i, 4) Case Is >= 14: RESULT = "امتياز" Case Is >= 8: RESULT = "جيد جد" Case Is >= 6: RESULT = "جيــــد" Case Is >= 4: RESULT = "مقبول" Case Is >= 2: RESULT = "ضعيف" Case Else:RESULT = vbNullString End Select Cells(i, 9) = RESULT Next End Sub

تم معالجة الامر BOOOk.xlsx

جرب هذه المعادلة =IF(OR(NOT(ISNUMBER(G6)),G6=""),"",VLOOKUP(G6*100,{0,"ضعيف";50,"مقبول";65,"جيد";75,"جيد جدا";85,"ممتاز";100,0},2)) الملف مرفق tartib_st.xlsx

وجود الخلايا المدمجة في الصفوف 26/27/28 و 30 يعيق عمل المعادلات لذلك رجاء لا تقم بدمج الخلايا حتى تحصل على النتيجة المطلوبة (تم ازالة الدمج) الملف مرفق Takem.xlsx

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Activate() FIL_data_val End Sub '++++++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("C5:F5")) Is Nothing And Target.Count = 1 Then new_filter End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++++++++ Sub new_filter() Dim i As Byte, k As Byte Dim LX%, RO%, x Dim arr() Dim st1, st2 Dim Rg As Range: Set Rg = Targt.Range("C5:F5") Dim Frg As Range: Set Frg = Source.Range("b8").CurrentRegion RO = Frg.Rows.Count k = 4: x = 0 On Error Resume Next If Source.AutoFilterMode Then Source.ShowAllData: Frg.AutoFilter End If On Error GoTo 0 Targt.Range("b8").CurrentRegion.ClearContents For i = 1 To k If Rg.Cells(i) <> "" Then x = x + 1 ReDim Preserve arr(1 To x): arr(x) = Rg.Cells(i) & "*" & i + 1 End If Next i On Error Resume Next LX = LBound(arr) If LX = 0 Then Frg.Copy Targt.Range("B8") GoTo End_Me End If On Error GoTo 0 For i = LBound(arr) To UBound(arr) st1 = Val(Split(arr(i), "*")(1)) st2 = Split(arr(i), "*")(0) Frg.AutoFilter Field:=st1, Criteria1:=st2 Next i Frg.SpecialCells(2, 23).Copy Targt.Range("B8") On Error Resume Next End_Me: If Source.AutoFilterMode Then Source.ShowAllData: Frg.AutoFilter End If End Sub الملف مرفق My_filter_new_1.xlsm

مش نعرف الاول مين هم العمال ومين هم المسؤولين

تم التعديل My_filter_new.xlsm

جرب هذا الملف My_filter.xlsm

وضعت المعادلة باللغة الفرنسية ويجب مقابلتها بنفس الدالة لكن باللغة الانكليزية مثلاً SIERREUR يقابلها IFERROR ولكن ماذا عن باقي الدالات

معادلة اخرى ربما اسهل =VLOOKUP(INT(CV2)-INT(D2),{0,"0day";1,"1day";2,"2days";3,"3days";4,"more than 3 days"},2) و اذا لم تعمل معك استبدل الفاصلة بفاصلة منقوطة(خارج الاقواس المعكوفة) لتبدو المعادلة هكذا =VLOOKUP(INT(CV2)-INT(D2);{0,"oday";1,"1day";2,"2days";3,"3days";4,"more than 3 days"};2)

استعمل هذه المعادلة =CHOOSE(IF(INT(CW2)-INT(E2)=0,1,0)+IF(INT(CW2)-INT(E2)=1,2,0)+IF(INT(CW2)-INT(E2)=2,3,0)+IF(INT(CW2)-INT(E2)=3,4,0+IF(INT(CW2)-INT(E2)>3,5,0)),"0day","1day","2day","3day","more than 3day") و اذا لم تعمل معك استبدل الفاصلة بفاصلة منقوطة لتبدو المعادلة هكذا =CHOOSE(IF(INT(CW2)-INT(E2)=0;1;0)+IF(INT(CW2)-INT(E2)=1;2;0)+IF(INT(CW2)-INT(E2)=2;3;0)+IF(INT(CW2)-INT(E2)=3;4;0+IF(INT(CW2)-INT(E2)>3;5;0));"0day";"1day";"2day";"3day";"more than 3day")

تم معالجة الأمر الماكرو الاول ما زال يعمل في حال اردت تشغيله من خلال الزر Simple filter Filter_by_choise_new.xlsm