سليم حاصبيا

لك ما تريد ترتيب الطلاب _salim.xlsm

لك ما تريد Salimتنسيق شرطى.xlsx

الطريقة التي تعتمدها صعبة لتنفيد ماكرو (مع أنها غير مستحيلة) و تتطلب ايضاً تحديد الـــ Print Areas لذلك قم بنسخ الجدول من A1 الى J21 الى عدة شيتات (كل شيت باسم طالب ) ,و تحدد فيها Print Areas من A1 الى J21 و نفذ الماكرو

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

هذا الماكرو يقوم بالمطلوب في كل الأوراق (قم بتنفيذ الماكرو الاول) Option Explicit Sub One_for_All_macro() Dim Sh_num% For Sh_num = 1 To Sheets.Count Sheets(Sh_num).Activate evaluate_result Next End Sub '============================= Sub evaluate_result() Dim my_arr() Dim i As Byte Dim k As Byte: k = 0 Dim st$: st = " يحتاح للعناية في: " Dim Mot Dim resulte$ For i = 5 To 9 If Range("d" & i) < Range("c" & i) / 2 Then ReDim Preserve my_arr(0 To k) my_arr(k) = Range("A" & i).Value k = k + 1 End If Next If k > 0 Then Mot = Join(my_arr, ",") Range("H4") = st & Chr(10) & Mot Exit Sub Else Select Case Range("d11") / Range("c11") * 100 Case Is >= 0.85: resulte = "ممتاز" Case Is >= 0.75: resulte = "جيد جدا" Case Is >= 0.65: resulte = "جيد" Case Is >= 0.5: resulte = "متوسط" Case Else: resulte = "راسب" End Select End If Range("H4") = resulte End Sub

حيث أن البيانات كبيرة بعض الشيء تم تعديل الماكرو ليكون اسرع قليلاُ (بضعة ثواني) Option Explicit Sub Destibute_Data_by_find() If ActiveSheet.Name <> "Sheet1" Then GoTo Leave_Me_Out Dim list As Object Dim Rng As Range, rcell As Range Dim y, x%, m%: m = 2 Dim my_rg As Range Dim Rg As Range Dim f_addres$ Application.ScreenUpdating = False Set list = CreateObject("System.Collections.ArrayList") Set Rng = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp)) '===================== For Each rcell In Rng.Cells If Not list.Contains(rcell.Value) _ And rcell.Value <> "" Then list.Add (rcell.Value) Next rcell '=============================== For x = 0 To list.Count - 1 With Sheets("Sheet" & list.Item(x)) .Cells.ClearContents .Range("c:c").NumberFormat = ("dd-mm-yyyy") Set Rg = Rng.Find(list.Item(x), _ after:=Rng.Cells(Rng.Rows.Count), _ LookIn:=xlValues, lookat:=xlWhole) If Not Rg Is Nothing Then f_addres = Rg.Address Do .Range("a" & m).Resize(, 5).Value = _ Range(Rg.Address).Resize(, 5).Value .Columns("C").AutoFit m = m + 1 Set Rg = Rng.FindNext(Rg) Loop While Not Rg Is Nothing And Rg.Address <> f_addres Else MsgBox "Non items" End If m = 4 End With Next Leave_Me_Out: Application.ScreenUpdating = True End Sub الملف مرفق _Salim ادارات.xlsm

اعمل شيتات بأي رقم تريد بالنسبة للمجال E يمكن استبدال الرقم 3 بالرقم 5 في عبارةٌ Resize من الكود

بالاذن من الاستاذأحمد هذا الماكرو ربما يفي بالمطلوب Option Explicit Sub evaluate_result() Dim my_arr() Dim i As Byte Dim k As Byte: k = 0 Dim st$: st = " يحتاح للعناية في: " Dim Mot Dim resulte$ For i = 5 To 9 If Range("d" & i) < Range("c" & i) / 2 Then ReDim Preserve my_arr(0 To k) my_arr(k) = Range("A" & i).Value k = k + 1 End If Next If k > 0 Then Mot = Join(my_arr, ",") Range("H4") = st & Chr(10) & Mot Exit Sub Else Select Case Range("d11") / Range("c11") * 100 Case Is >= 0.85: resulte = "ممتاز" Case Is >= 0.75: resulte = "جيد جدا" Case Is >= 0.65: resulte = "جيد" Case Is >= 0.5: resulte = "متوسط" Case Else: resulte = "راسب" End Select End If Range("H4") = resulte End Sub الملف مرفق Aziz_salim.xlsm

جرب هذا الماكرو Option Explicit Sub Destibute_Data() Dim list As Object Dim Rng As Range, rcell As Range Dim y, x, m%: m = 4 Dim my_rg As Range Application.ScreenUpdating = False Set list = CreateObject("System.Collections.ArrayList") Set Rng = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp)) For Each rcell In Rng.Cells If Not list.Contains(rcell.Value) _ And rcell.Value <> "" Then list.Add (rcell.Value) Next rcell For x = 0 To list.Count - 1 Sheets("Sheet" & list.Item(x)).Cells.ClearContents For y = 4 To Rng.Rows.Count If Sheets("sheet1").Range("a" & y) = list.Item(x) Then Sheets("Sheet" & list.Item(x)).Range("a" & m).Resize(, 3).Value = _ Sheets("sheet1").Range("a" & y).Resize(, 3).Value m = m + 1 End If Next m = 4 Next Application.ScreenUpdating = True End Sub الملف مرفق ادارات.xlsm

بعد اذن اخي بن علية معادلة اخرى (CTRL+SHIFT+ENTER) =IFERROR(INDEX(الموقف!$B$2:$B$100,MATCH(2,($A2=الموقف!$C$2:$C$100)+($B2=الموقف!$A$2:$A$100),0)),"") و هذه ايضاً (CTRL+SHIFT+ENTER) =IF(COUNTA($A2:$B2)<2,"",INDEX(الموقف!$B$2:$B$100,LOOKUP(MAX($B$2:$B$100)+1,(IF(الموقف!$B$2:$B$100<>"",IF(الموقف!$C$2:$C$100=$A2,IF(الموقف!$A$2:$A$100=$B2,ROW($D$2:$D$100)-ROW($D$2)+1)))))))

كيف تريدني ان اعمل على جدول فارغ تماماً

جرب هذا الماكرو Option Explicit Sub copy_paste() Dim lr1%: lr1 = Sheets("Sheet1").Cells(Rows.Count, "D").End(3).Row + 2 lr1 = IIf(lr1 = 3, 1, lr1) Dim lr2%: lr2 = Sheets("Sheet2").Cells(Rows.Count, "D").End(3).Row Dim i%: i = 1 Dim col As Object Set col = CreateObject("System.Collections.ArrayList") With col Do Until i > lr2 If Sheets("Sheet2").Range("D" & i) <> vbNullString Then .Add Sheets("Sheet2").Range("D" & i).Value End If i = i + 1 Loop Sheets("Sheet1").Range("d" & lr1).Resize(.Count - 1) = _ Application.Transpose(.toarray) End With End Sub الملف مرفق Bookaa.xlsm

Test This Simple ALL_SUM.xlsx

هذه المعادلة في الخلية A2 واسحب نزولاً =IF(B2="","",SUBTOTAL(103,$B$2:B2)) اذا لم تعمل معك استبدل الفاصلة بفاصلة منقوطة لتصبح هكذا =IF(B2="";"";SUBTOTAL(103;$B$2:B2)) File included _salimتصفية.xlsx

هذه المعادلة =SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A2&":"&B2)))<>3)*(WEEKDAY(ROW(INDIRECT(A2&":"&B2)))<6))-SUMPRODUCT(--(ROW(INDIRECT(A2&":"&B2))=$E$2:$J$2)) الملف مرفق أيام الشهر 2.xlsm

لحساب التاواريخ المستثناة هذه المعادلة يجب تطبيقها ياستعمال (Ctrl+Shift+Enter) وليس Enter وحدها =SUMPRODUCT((WEEKDAY($N$4:$N$34)<6)*(WEEKDAY($N$4:$N$34)<>3))-SUMPRODUCT(IF(ISNUMBER(MATCH($E$2:$J$2,$N$4:$N$34,0)),1,0))

هذه المعادلة =SUMPRODUCT((WEEKDAY($N$4:$N$34)<6)*(WEEKDAY($N$4:$N$34)<>3))

استبدل الكود الى هذا Option Explicit Sub Show_hide_col() Application.ScreenUpdating = False Dim my_rg As Range Dim i% Dim t As Byte t = IIf([b1] = "اداري", 1, 2) Set my_rg = Range("E1:AT1") my_rg.Columns.Hidden = True For i = 1 To my_rg.Columns.Count With my_rg.Cells(i) If .Value = t Or _ .Value = vbNullString Then _ .EntireColumn.Hidden = False End With Next Application.ScreenUpdating = True End Sub Rem================================= Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$1" Then Show_hide_col End If Application.EnableEvents = True End Sub الملف معدل _salimمرتبات.xlsm

جرب هذا الملف الكود Sub Show_hide_col() Application.ScreenUpdating = False Dim my_rg As Range Dim i%, x% Dim t As Byte t = IIf([b1] = "اداري", 1, 2) Set my_rg = Range("E1:AT1") my_rg.Columns.Hidden = False x = my_rg.Columns.Count For i = 1 To x If my_rg.Cells(i) <> t Then my_rg.Cells(i).EntireColumn.Hidden = True End If Next Application.ScreenUpdating = True End Sub Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$1" Then Show_hide_col End If Application.EnableEvents = True End Sub الملف مرفق مرتبات.xlsm

هذا الماكرو Option Explicit Sub Merg_for_Me() Dim i% Columns("A:B").UnMerge For i = 1 To 100 Step 2 Range("a" & i & ":a" & i + 1).Merge Range("b" & i & ":b" & i + 1).Merge Next End Sub

ربما كان عندك نظام التاريخ بتنسيق اميركي شهر /يوم/ سنة mm/dd/yyyy لذلك يجب اما ان تغير نظام التاريخ الى انكليزي dd/mm/yyyyy او ان تكتب تاريخ البداية والنهاية(والتواريخ في الصف الثّاني) بكتابة الشهر أولاً ثم اليوم ثم السنة مثلاً 25/1/2019 تكتب هكذا 1/25/2019

الحل هنا Salim_book.xlsx

الملف الذي رفعته فارغ

جرب هذا الملف من ملغاتي القديمة wprking_days_Vba.xlsm

مع انك لم ترفع ملف للمعالجة اليك هذا النموذج Alamat.xlsx