سليم حاصبيا

المعادلة المطلوبة =IFERROR(VLOOKUP(A2,$H:$H,1,0),0)

اختي الفاضلة ساجدة انا من متابعي فيديوهاتك الرائعة كان من المفروض ان تنضمي حضرتك الينا في المنتدى منذ فترة طويلة كم نحن بحاجة الى هكذا عالم عليم من أعلام الاكسل و عباقرتها تشرفنا بحضرتك في عداد الأعضاء المميزين جداً و ننتظر الترقية بفارغ صبر

احذف هذا السطر من الكود و ترى كل شيء كما تريد Cells(2, "F").Resize(.Count - 1) = _ Application.Transpose(.Items)

جرب هذا الكود Option Explicit Sub Find_all() Dim S As Worksheet Dim D As Object Dim Ro%, k%, a, b, c Set S = Sheets("sheet1") Set D = CreateObject("Scripting.Dictionary") S.Range("E1").CurrentRegion.Offset(1).ClearContents Ro = S.Cells(Rows.Count, 2).End(3).Row With D k = 2 Do Until k = Ro + 1 If S.Range("B" & k) <> vbNullString Then Select Case S.Range("B" & k) Case "الشرقية": a = a + 1 Case "الغربية": b = b + 1 Case "القاهرة": c = c + 1 End Select If Not D.exists(S.Range("B" & k).Value) Then D.Add (S.Range("B" & k).Value), _ IIf(IsNumeric(S.Range("C" & k).Value), S.Range("C" & k).Value, 0) Else D(S.Range("B" & k).Value) = D(S.Range("B" & k).Value) + _ IIf(IsNumeric(S.Range("C" & k).Value), S.Range("C" & k).Value, 0) End If End If k = k + 1 Loop Cells(2, "E").Resize(.Count - 1) = _ Application.Transpose(.keys) Cells(2, "F").Resize(.Count - 1) = _ Application.Transpose(.Items) Cells(2, "G") = a Cells(3, "G") = b Cells(4, "G") = c .RemoveAll End With Set D = Nothing: Set S = Nothing End Sub الملف مرفق Example.xlsm

اولاً عملية دمج الخلايا غير محببة في الاكسل (خاصة اذا كان هناك معادلات) تم الغاء الدمج ثانياً جرب هذا الملف Elecrique Facture .xlsm

العذر مقبول اليك الملف Creasy_data_val_1.xlsx

يمكنك استعمال هذا الماكرو ولا حاجة لاشغال البرنامج بأكثر من 1300 معادلة SumIf Option Explicit Sub Find_all() Dim S As Worksheet Dim D As Object Dim Ro%, k% Set S = Sheets("sheet1") Set D = CreateObject("Scripting.Dictionary") S.Range("h2").CurrentRegion.Offset(1).ClearContents Ro = S.Cells(Rows.Count, 1).End(3).Row With D k = 2 Do Until k = Ro + 1 If S.Range("A" & k) <> vbNullString Then If Not D.exists(S.Range("A" & k).Value) Then D.Add (S.Range("A" & k).Value), _ IIf(IsNumeric(S.Range("B" & k).Value), S.Range("B" & k).Value, 0) Else D(S.Range("A" & k).Value) = D(S.Range("A" & k).Value) + _ IIf(IsNumeric(S.Range("B" & k).Value), S.Range("B" & k).Value, 0) End If End If k = k + 1 Loop Cells(2, "H").Resize(.Count - 1) = _ Application.Transpose(.keys) Cells(2, "I").Resize(.Count - 1) = _ Application.Transpose(.Items) Cells(2, "j") = .Count - 1 .RemoveAll End With Set D = Nothing: Set S = Nothing End Sub الملف مرفق Sum Of Unique.xlsm

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

عليك بهذه المعادلة =IF(NOT(ISNUMBER(A2)),"",CHOOSE((MOD(A2,1)<0.5)+1,CEILING(A2,0.5),FLOOR(A2,0.5))) الملف مرفق Question.xlsx

جرب هذه المعادلة في الخلية I6 =IF(H6>$H$1,G6,IF(H6>$H$2,CHOOSE((G6-J6<=0)+1,G6-J6,G6),0))

في الخلية C10 هذه المعادلة =MOD(ROUND(B10,3),1)*1000 في الخلية D10 هذه المعادلة =QUOTIENT(B10,1) اذا لم تعمل استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =MOD(ROUND(B10;3);1)*1000 AND =QUOTIENT(B10;1)

هذه العلامة تشير ان الملف يحتوي على ماكرو

حجم الملف كبير جداً حوالي(7000 صف) لذلك من المفترض ان يأخد وقتاً للتنفيذ الكود الملف المرفق نموذج عما تريد (فقط حوالي 50 صف) لمتابعة عمل الكود الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("A4:g4")) Is Nothing And _ Target.Count = 1 Then Range("A4:g4").Interior.ColorIndex = 40 Target.Interior.ColorIndex = 6 Call find_please(Target.Row, Target.Column) End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++ Sub find_please(IRow, ICol) Dim R As Worksheet, L As Worksheet Dim S_rg As Range 'Source range Dim m%, Ro%, i% Set R = Sheets("recherche") Set L = Sheets("liste") Set S_rg = L.Range("a2", L.Range("G1").End(4)) Ro = S_rg.Rows.Count For i = 1 To 7 If i <> ICol Then R.Cells(IRow, i) = vbNullString End If Next R.Range("A9").CurrentRegion.Offset(1).ClearContents m = 10 For i = 1 To Ro If UCase(Mid(S_rg.Columns(ICol).Cells(i), 1, Len(R.Cells(IRow, ICol)))) = _ UCase(R.Cells(IRow, ICol)) Then R.Cells(m, 1).Resize(, 7).Value = _ S_rg.Rows(i).Value m = m + 1 End If Next End Sub الملف مرفق list_saerch.xlsm

الاجابة هنا (الجدول الاصفر) 3 أرقام - 4 ارقام / 3 ارقام Creasy_data_val.xlsx

جرب هذا الكود مجرد ان تختار الصف من اي قائمة منسدلة يقوم الكود بعمله Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("All_class")) Is Nothing _ And Target.Count = 1 Then If Target = vbNullString Then Target.Offset(3, -2).Resize(10, 3).ClearContents GoTo Exit_me Else get_10_studiants (Sheets("first").Range(Target.Address)) End If End If Exit_me: Application.EnableEvents = True End Sub '========================= Sub get_10_studiants(rg As Range) Dim A As Worksheet, F As Worksheet Dim find_rg As Range, cel As Range Dim my_clas$, t Dim Obj As Object Dim x%, LF%, Ro%, first%, last%, i% Dim arr(9), Copy_rg As Range Dim adrs$ Set A = Sheets("ALL_STD") Set F = Sheets("first") my_clas = rg adrs = rg.Address rg.Offset(3, -2).Resize(10, 3).ClearContents Set Copy_rg = rg.Offset(3, -2).Resize(10, 3) Ro = A.Cells(Rows.Count, 1).End(3).Row Set Obj = CreateObject("System.collections.arraylist") Set find_rg = A.Range("a:a").Find(my_clas, lookat:=1) If Not find_rg Is Nothing Then first = find_rg.Row: last = first Do Obj.Add A.Range("AF" & last).Value Set find_rg = A.Range("a:a").FindNext(find_rg) last = find_rg.Row If last = first Then Exit Do Loop End If Obj.Sort: Obj.Reverse For i = 0 To 9 Copy_rg.Cells(1, 1).Offset(i) = i + 1 arr(i) = Obj(i) Next Copy_rg.Cells(1, 3).Resize(i) = Application.Transpose(arr) For Each cel In Copy_rg.Columns(2).Cells t = "=INDEX(ALL_STD!$B$3:$B$710,MATCH(" & adrs & "&" & cel.Offset(, 1) & _ ",ALL_STD!$A$3:$A$710&ALL_STD!$AF$3:$AF$710,0))" cel = Evaluate(t) Next End Sub الملف مرفق Many_Class_In One_Sheet.xlsm

حمل الملف لوضع اليد على الخطأ وتصحيحه

الاجابة في النطاق الاصفر من هذا الملف Spec_Char.xlsx

لا اعمل مع ملف مسماتة شيتاته باللغة العربية( اكثر من مرة ذكرت ذلك) غير اسماء الصفحات الى اللغة الاجنبية و سأحاول المساعدة

جرب هذا الكود Option Explicit Private Sub Worksheet_Activate() fil_dat_val End Sub '+++++++++++++++++++++++++++++++++++ Sub fil_dat_val() Application.ScreenUpdating = False Dim I%: I = 6 Dim arr Dim rg As Object Set rg = CreateObject("system.collections.arraylist") With rg Do Until Sheets("sheet1").Range("B" & I) = vbNullString If Not .contains(Sheets("sheet1").Range("A" & I).Value) Then _ .Add Sheets("sheet1").Range("A" & I).Value I = I + 1 Loop .Sort arr = .toarray arr = Join(arr, ",") End With With Sheets("sheet2").Range("H2").Validation .Delete .Add xlValidateList, Formula1:=arr End With End Sub '============================== Sub get_values() Dim rg As Object, I%, m%, kY Dim Sh1 As Worksheet, Sh2 As Worksheet I = 6 Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") Set rg = CreateObject("Scripting.dictionary") Sh2.Range("a6").CurrentRegion.Offset(1).Clear With Sh1 Do Until Not IsNumeric(.Range("a" & I)) If .Range("A" & I) = Sh2.Range("h2") _ And .Range("C" & I) >= Sh2.Range("I2") _ And .Range("C" & I) <= Sh2.Range("J2") Then rg(m) = _ .Range("C" & I).Value & "*" & _ .Range("D" & I).Value & "*" & _ .Range("E" & I).Value m = m + 1 End If I = I + 1 Loop End With If rg.Count = 0 Then GoTo End_Me m = 6 For Each kY In rg.keys Sh2.Cells(m, 1).Resize(, 3) = _ Split(rg(kY), "*"): m = m + 1 Next With Sh2.Range("A6:C" & m - 1) .Value = .Value .InsertIndent 1 .Borders.LineStyle = 1 .Font.Size = 14 End With End_Me: Application.ScreenUpdating = True Set rg = Nothing End Sub Saerch_by_date.xlsm

الكود يرحل عندما تغير شيئاً في الخلية k4 فقط الازار وضعت اذا كنت تريد ان تفرغ اي شيت من الشيتات( اختيارياً)

TRY THIS FILE ROW_NYMMBER.xlsx

جرب هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$K$4" And Target.Count = 1 Then get_data End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++ Sub get_data() Dim T As Worksheet, Mb As Worksheet, Msh As Worksheet Dim Opt_sh As Worksheet Dim Str$, Ro_T%, Opt_ro% Set T = Sheets("Tarhil") Set Mb = Sheets("Mab") Set Msh = Sheets("Moush") Str = T.Cells(4, "K") Select Case Str Case "المبيعات": Set Opt_sh = Mb Case "المشتريات": Set Opt_sh = Msh Case Else: Exit Sub End Select Opt_ro = Opt_sh.Cells(Rows.Count, 1).End(3).Row Opt_ro = IIf(Opt_ro = 3, 4, Opt_ro + 2) Ro_T = T.Range("b9").CurrentRegion.Rows.Count If Ro_T > 1 Then Opt_sh.Range("A" & Opt_ro).Resize(Ro_T - 1, 12).Value = _ T.Range("b10").Resize(Ro_T - 1, 12).Value Else MsgBox "No data to transfer" Exit Sub End If End Sub '================================= Sub clear_all_Mab() Sheets("Mab").Range("A3").CurrentRegion.Offset(1).Clear End Sub '================================= Sub clear_all_Moush() Sheets("Moush").Range("A3").CurrentRegion.Offset(1).Clear End Sub الملف مرفق Book_sal.xlsm

جرب هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$C$5" And Target.Count = 1 Then get_10_studiants End If Application.EnableEvents = True End Sub '========================= Sub get_10_studiants() Application.ScreenUpdating = False Dim A As Worksheet, F As Worksheet Dim find_rg As Range Dim my_clas$ Dim Obj As Object Dim x%, LF%, Ro%, first%, last%, i% Dim arr(9) Set A = Sheets("ALL_STD") Set F = Sheets("first") my_clas = F.Range("C5") LF = F.Cells(Rows.Count, "b").End(3).Row If LF < 8 Then LF = 8 F.Range("A8:C" & LF).ClearContents Ro = A.Cells(Rows.Count, 1).End(3).Row Set Obj = CreateObject("System.collections.arraylist") Set find_rg = A.Range("a:a").Find(my_clas, lookat:=1) If Not find_rg Is Nothing Then first = find_rg.Row: last = first Do Obj.Add A.Range("AF" & last).Value Set find_rg = A.Range("a:a").FindNext(find_rg) last = find_rg.Row If last = first Then Exit Do Loop End If Obj.Sort: Obj.Reverse For i = 0 To 9 F.Range("A8").Offset(i) = i + 1 arr(i) = Obj(i) Next F.Range("c8").Resize(i) = Application.Transpose(arr) F.Range("B8").Resize(i).Formula = _ "=IFERROR(INDEX(ALL_STD!$B$8:$B$706,MATCH(C8,ALL_STD!$AF$8:$AF$706,0)),"""")" F.Range("a7").CurrentRegion.Value = _ F.Range("a7").CurrentRegion.Value End Sub الملف مرفق First_10.xlsm

جرب هذا الكود Option Explicit Sub test_me() Dim Sh As Worksheet, D As Worksheet Dim first#, last#, i#, Ro# Dim my_rg As Range, find_rg As Range Dim adres#, Obj As Object Set Sh = Sheets("Sheet1"): Set D = Sheets("DATA") Set Obj = CreateObject("System.collections.arraylist") Ro = Sh.Cells(Rows.Count, 1).End(3).Row adres = [TELE].Offset(, -1).Find("").Row Set my_rg = D.Range("B2").Resize(adres - 2) For i = 5 To Ro Set find_rg = my_rg.Find(Sh.Range("A" & i).Value, lookat:=1) If Not find_rg Is Nothing Then first = find_rg.Row: last = first Do Obj.Add D.Range("C" & last).Value Set find_rg = my_rg.FindNext(find_rg) last = find_rg.Row If last = first Then Exit Do Loop End If ' Obj.Sort Sh.Range("C" & i) = Obj(Obj.Count - 1) Obj.Clear Next End Sub الملف مرفق Abu_Alaa.xlsm

جرب هذا الملف My_Book2.xls