سليم حاصبيا

هذه المعادلة =CEILING(A2,5) واذا لم تعمل معك استبدل الفاصلة " , "بفاصلة منقوطة ";" لتصبح هكذا =CEILING(A2;5)

جرب هذا الملف File_1.xlsx

لا أفهم طريقة الحصول على الرقم 116 في الخلية N3

See this video https://www.youtube.com/watch?v=-WAEzokHSJM

مبادرة واسطة الماكرو مع حرية اختيار ايام الجمعة والسبت الكود Option Explicit Sub How_many_week_day() Application.ScreenUpdating = False With Sheets("salim") Dim t_sun%, t_mon%, t_tue%, t_wed% Dim t_thu%, t_fri%, t_sat% Dim Start_D As Date, End_D As Date Dim k%: k = 1 Dim it As Range, I_Have_this% Dim lr%: lr = .Cells(Rows.Count, 1).End(3).Row .Range("d5").Resize(lr - 4, 10).ClearContents Dim x#, t% Dim Comp_Rg As Range Dim Arr() Set Comp_Rg = .Range("v5:v100") For Each it In Comp_Rg If IsDate(it) Then ReDim Preserve Arr(1 To k) Arr(k) = Weekday(it) k = k + 1 End If Next it For k = 5 To lr If IsDate(.Range("B" & k)) And IsDate(.Range("C" & k)) Then Start_D = .Range("B" & k): End_D = .Range("C" & k) For x = Start_D To End_D If IsError(Application.Match(x, Comp_Rg, 0)) Then Select Case Weekday(x) Case 1: t_sun = t_sun + 1 Case 2: t_mon = t_mon + 1 Case 3: t_tue = t_tue + 1 Case 4: t_wed = t_wed + 1 Case 5: t_thu = t_thu + 1 Case 6: t_fri = t_fri + 1 Case 7: t_sat = t_sat + 1 End Select End If t = t + 1 Next x .Range("d" & k) = t_sun: .Range("E" & k) = t_mon .Range("F" & k) = t_tue: .Range("G" & k) = t_wed .Range("H" & k) = t_thu .Range("I" & k) = IIf([m2] = "نعم", t_fri, vbNullString) .Range("J" & k) = IIf([m2] = "نعم", t_sat, vbNullString) .Range("L" & k) = t .Range("M" & k) = Evaluate("SUM(D" & k & ":J" & k & ")") '==================================== End If t_sun = 0: t_mon = 0: t_tue = 0: t_wed = 0: t_thu = 0: t_fri = 0: t_sat = 0: t = 0 Next .Range("O2") = UBound(Arr) Erase Arr End With Application.ScreenUpdating = True End Sub الملف مرفق (الصفحة Salim) work_date.xlsm

المزيد في هذا الملف حيث يتم ادراح مقاطع صفحات الطباعة (كل 25 اسم على لائحة منفردة) الكود Option Explicit Sub Give_Me_Printing_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") Dim m%: m = 1 Dim Arr() Dim final_row With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) ReDim Preserve Arr(1 To m) Arr(m) = Max_ro + 3 m = m + 1 Next '=================================== With Sheets("Archive") final_row = ws2.Cells(Rows.Count, "E").End(3).Row Arr(UBound(Arr)) = final_row + 2 .PageSetup.PrintArea = .Range("c5:j" & final_row + 1).Address .ResetAllPageBreaks .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 For k = 1 To UBound(Arr) - 1 If k = UBound(Arr) - 1 Then .HPageBreaks.Add Before:=.Cells(Arr(k) + 3, 1) Else .HPageBreaks.Add Before:=.Cells(Arr(k) + 1, 1) End If Next End With '================================ MsgBox "That is All" & Chr(10) & "You have " & Capcity & " Pages To Print" _ & Chr(10) & "Good Luck From Salim" With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With Erase Arr End Sub الملف من حديد Print_ALL_In_one_sheet.xlsm

جرب هذا الكود Option Explicit Sub give_Data() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Nous As Worksheet: Set Nous = Sheets("شيت نص السنة") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Nous_ro%: Nous_ro = Nous.Cells(Rows.Count, 1).End(3).Row Kaleb.Range("a2:t5000").ClearContents Dim Rg_Nous As Range: Set Rg_Nous = Nous.Range("a1:G" & Nous_ro) Dim Nous_r%: Nous_r% = Rg_Nous.Rows.Count Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Nous If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Nous.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Nous.Offset(1, 0).Resize(Nous_r% - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Kaleb.Cells(m, 1).Resize(Y, 6).Value = _ Filter_range.Areas(t).Cells(1, 1).Resize(Y, 6).Value Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With give_Data1 End Sub Rem============================================= Sub give_Data1() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Shahr As Worksheet: Set Shahr = Sheets("شيت الشهري") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Shahr_ro%: Shahr_ro = Shahr.Cells(Rows.Count, 1).End(3).Row Dim Rg_Shahr As Range: Set Rg_Shahr = Shahr.Range("a1:G" & Shahr_ro) Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Shahr If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Shahr.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Shahr.Offset(1, 0).Resize(Shahr_ro - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col - 1).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With End Sub الملف simple_data.xlsm

1-حيث ان البيانات كثيرة جداً فقد تم اختصار الملف الى حوالي 100 اسم للتحقق من عمل الماكرو (يمكن الان تعميم الماكرو على كل الملف) 2-هناك خلايا مدمجة في الملف مما يعيق عمل الماكرو (تم التعدبل على بنية الملف لازالة الخلايا المدمجة) 3-في المرة المقبلة حاول تجنب الخلايا المدمحة واختصار الملف الى أقل عدد ممكن من البيانات 4- تم معالجة الامر في الملف المرفق 5- ارجو ان ينال الاعجاب الكود Option Explicit Sub Give_Me_Data_Please() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Data As Worksheet Dim ws2 As Worksheet Set Data = Sheets("data") Set ws2 = Sheets("Archive") With ws2 .Range("a38:j10000").ClearContents .Range("c10:j34").ClearContents End With Dim Capcity%, i%, k%, Max_ro% Dim ro%: ro = 39 Dim first_row%: first_row = 10 Dim lr_data% lr_data = Data.Application.Max(Data.Range("A:A")) Capcity = lr_data \ 25 If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1 For k = 1 To Capcity - 1 ws2.Range("c5:j37").Copy ws2.Range("c" & ro) ro = ro + 33 Next For i = 6 To lr_data + 25 Step 25 ws2.Range("c" & first_row).Resize(25, 5).Value = _ Data.Range("a" & i).Resize(25, 5).Value Max_ro = ws2.Range("c:c"). _ Find(Application.Max(ws2.Range("c:c"))).Row first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9) Next With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف ALL_In_one_sheet.xlsm

استبدل في المعادلة الفاصلة ", " بفاصلة منقوطة "; " لتصبح بهذا الشكل ( حسب اعدادات الجهاز عندك) =IF(C2="";"";2*QUOTIENT(C2;100000))

في الخلية اكتب هذه المعادلة واسحب نزولاً =IF(C2="","",2*QUOTIENT(C2,100000))

لا تنتظر أن يقوم احد من الاساتذة بإنشاء ملف يحتوي عما تريد ارفع الملف للمعاينة والتفكير في الحل

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

ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق الرجاء النظر الى هذه الملف لمعرفة ما أعنية من وجهة نظر السرعة Search_by_find_timer .xlsm

ربما كان هذا الكود اسرع بحوالي 100 مرة باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق Search_by_find.xlsm

رمضان كريم و صوم مبارك اخي مصطفي شخصياً ارى ان الملف كبير جداً لانشاء حلقات تكرارية (حوالي 20.000 حلقة) لذلك اقترح ادراج كود يعمل على Advanced Filter (اختصاراً للوقت عند تنفيذ الكود)

رمضان كريم و مبارك على الحميع بعد اذن اخي بن علية في حال استعمال الكود يمكن عمل ذلك بدون أعمدة مساعدة ( أقصد العامود T ) و حتى بدون معادلات Countif الكود Option Explicit Sub Salim_Unique_Data_And_count() Dim Rng As Range [b9:i10].ClearContents Dim dt As Object Set dt = CreateObject("Scripting.Dictionary") For Each Rng In [B2:I6] If Rng.Value <> vbNullString Then dt(Rng.Value) = _ IIf(Not dt.exists(Rng.Value), 1, dt(Rng.Value) + 1) End If Next Range("b9").Resize(1, dt.Count) = dt.Keys Range("b10").Resize(1, dt.Count) = dt.Items dt.RemoveAll: Set dt = Nothing End Sub الملف مرفق My_count_Salim.xlsm

My_count1.xlsx

الحل هنا My_count.xlsx

الملف كبير جداً عشرين الف صنف (كيف لك ان تتذكر ارقامها كلها ) ارى الأفضل ان تقوم بالتصفية على اسم التاجر

السؤال غير مفهوم املأ الجدول يدوياً وارفع الملف من جديد لمعرفة المطلوب

رمضان كربم ومبارك عليكم بعد اذن اخي مصطفى لعل كان المقصود بالسؤال هذا الملف tekrar by_choise.xlsx

بعد اذن أخي بن علية هذا الحل (في الخلية P2 تضع قيمة الحد الأدنى اذ ربما احببت ان تغير قيمته) المعادلة =IF(COUNTA($B2:$C2)<2,"",MAX(OFFSET($O$2,MATCH(C2,$N$2:$N$4,0)-1,,)*$B2,$P$2)) الملف مرفق Classeur_salim.xlsx

لنسخ القيم فقط هذا الكود Option Explicit Sub Copy_range_Values() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim My_max%: My_max = Application.Max(Sheets("الربط").Range("f:f")) With Sheets("العمليات").Range("f5") .Resize(500, 54).ClearContents .Resize(My_max + 1, 54).Value = _ Sheets("الربط").Range("f5").Resize(My_max + 1, 54).Value End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف من جديد Omra_values.xlsm

لا تنتظر أن يقوم احد من الاساتذة بإنشاء ملف يحتوي عما تريد ارفع الملف للمعاينة والتفكير في الحل

هذه المعادلة في الخلية D16 واسحب نزولاً =SUMPRODUCT(--($C$4:$C$13=$C16),$D$4:$D$13)