سليم حاصبيا

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

بعد اذن الاخ ابراهيم هذا الكود Option Explicit Sub Multi_Sum() Dim LR%, t%, m% With Sheets("Sheet1") LR = .Range("A" & Rows.Count).End(xlUp).Row For t = 1 To LR If Application.CountA(.Cells(t, 1).Resize(, 2)) = 1 Then .Cells(t, 1) = vbNullString End If Next m = .Range("A1", Range("A1").End(4)).Rows.Count t = 1 Do Until t > LR With .Range("A" & t + m) .Formula = _ "=SUM(A" & t & ":B" & t + m - 1 & ")" .Value = .Value End With t = t + m + 2 Loop End With End Sub الملف مرفق ahmed sherif.xlsm

بعد اذن اخي المهندس هذا الملف بتنسيقات مختلفة وبدون التعداد الزائد (1 /2 / 3 الخ....) Canionettes.xls

كنت قد وضعتها لكن بالخطأ قد حذفتها https://www.youtube.com/watch?v=vx-oyYEx7LE&ab_channel=قناةساجدةالعزاويالتعليمية

Ab_has.xlsm

الكود Sub hid_rows() Dim Hide_range As Range Dim i% i = 5 Range("A5").CurrentRegion.EntireRow.Hidden = False Do Until Cells(i, 1) = vbNullString If Application.CountIf(Cells(i, 2).Resize(, 9), 0) = 9 Then If Hide_range Is Nothing Then Set Hide_range = Cells(i, 1) Else Set Hide_range = Union(Hide_range, Cells(i, 1)) End If End If i = i + 1 Loop If Not Hide_range Is Nothing Then Hide_range.EntireRow.Hidden = True End If End Sub '+++++++++++++++++ Sub show_all_rows() Range("A5").CurrentRegion.EntireRow.Hidden = False End Sub

لا أعلم بالضبط اذا كان هذا المطلوب Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.EnableEvents = False Dim RG As Range Dim i%, x%, lr% lr = Cells(Rows.Count, 1).End(3).Row If lr < 6 Then lr = 12 x = Cells(5, Columns.Count).End(1).Column Range("d5").Resize(lr - 1, x - 3).Interior.ColorIndex = xlNone Set RG = Range("d5").Resize(, x - 3) If Not Intersect(Target, RG) Is Nothing And Target.Count = 1 Then Target.Resize(lr - 1).Interior.ColorIndex = 6 End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++++ Sub MERGE_CELLS() Dim RG As Range Dim i%, x%, t%, lr% Application.ScreenUpdating = False Unmge lr = Cells(Rows.Count, 1).End(3).Row If lr < 6 Then lr = 12 x = Cells(5, Columns.Count).End(1).Column Cells(4, 4).Resize(lr, x).Borders.LineStyle = 1 Set RG = Cells(4, 4) For i = 4 To x If Month(Cells(5, i)) = Month(Cells(5, i + 1)) Then Set RG = Union(RG, RG.Offset(, 1)) RG.Merge Else Set RG = Cells(4, i + 1) End If RG = " شهر:" & Month(Cells(5, i)) Next Cells(4, x + 1).Resize(lr, 20).Clear For i = 4 To x If Cells(4, i).MergeCells Then t = Cells(4, i).MergeArea.Columns.Count Cells(4, i).Resize(lr, t).BorderAround 1, 3 i = i + t - 1 End If Next Cells(4, 4).Resize(, x - 3).BorderAround 1, 3 Application.ScreenUpdating = True End Sub '+++++++++++++++ Sub Unmge() Dim x%, Ro% Ro = Cells(Rows.Count, 1).End(3).Row If Ro < 6 Then Ro = 12 x = Cells(5, Columns.Count).End(1).Column Application.DisplayAlerts = False With Range("d4").Resize(Ro, x) .UnMerge .Rows(1) = vbNullString .Borders.LineStyle = 1 End With Application.DisplayAlerts = True End Sub الملف مرفق من جديد New_merge_Fouzi.xlsm

جرب هذا الشيء Hayatmi.xlsb

انا مسحت الملف من عبدي لعدم الحاجة اليه ارفعي الملف من جديد

تفضل مع زيادة حبتين الموسطي.xlsx

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

السؤال غير مفهوم أين تريدين المعادلة (أقصد في اي عامود) ارفعي جدولاُ بالنتائج التي تتوقعينها (غير الجدول الأصلي بل الى جانبه ) و دون حلايا فارغة فيه

ارجع Borders.LineStyle = xlNo الى 1 أضف الى الكود هذا السطر في المكان المناسب (حسب الصورة)

استبدل في هذا السطر الرقم 1 بـــ xlNo .Borders.LineStyle = 1

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

تم معالجة الأمر Odd_Even_Numbering.xlsm

انا لم اجذف الشيتات بل احفيتها لحسن الرؤية

السؤال كان واضحاً من المشاركة الأول أريد التعديل على المعادلة أو كود لجلب الطلبة لشيت اللجنة حسب المادة وحسب الجنس وهذا ليس خطأي انك لم تذكر شيت المصدر لذلك أعتذر عن المتابعة بهذا الموضوع

تصحيح المعادلات في الصف الخامس (ضروري) جرب هذا الكود Option Explicit Sub MERGE_CELLS() Dim RG As Range Dim i%, x% Application.ScreenUpdating = False x = Cells(5, Columns.Count).End(1).Column Application.DisplayAlerts = False With Range("d4").Resize(, x) .UnMerge .Value = vbNullString .Borders.LineStyle = 1 End With Application.DisplayAlerts = True Set RG = Cells(4, 4) For i = 4 To x If Month(Cells(5, i)) = Month(Cells(5, i + 1)) Then Set RG = Union(RG, RG.Offset(, 1)) RG.Merge Else Set RG = Cells(4, i + 1) End If RG = " شهر:" & Month(Cells(5, i)) Next Cells(4, x + 1).Resize(50, 20).Clear Application.ScreenUpdating = True End Sub '+++++++++++++++ Sub Unmge() Dim x% x = Cells(5, Columns.Count).End(1).Column Application.DisplayAlerts = False With Range("d4").Resize(, x) .UnMerge .Value = vbNullString .Borders.LineStyle = 1 End With Application.DisplayAlerts = True End Sub الملف مرفق Merge_Fouzy.xlsm

1-للمرة الـ 100 بعد الألف اختصار الملف ( لماذا اكثر من 500 طالب في كل ورقة) 2- انت وضعت 6 لجان كل واحدة تحتوي عل 15 اسم اي 90 طالب ما ادراك بعدد الطلاب (دور ثاني - ذكور او أناث) كيف تعرف ان 6 لجان نكفيهم ربما نحتاج الى 7 مثلاً أو 5 أو 10 3- كيف نعرف ان الطالب دور ثاني 4- على كل حال جرب هذا الماكرو Option Explicit Sub Get_data() Application.EnableEvents = False Dim s_rg As Range, find_rg As Range Dim Mou3addaL#, last_Clas%, I%, m%, col% Dim Mal_Femal$ Dim First_sheet As Worksheet Dim Second_sheet As Worksheet Dim Position%, k% Position = 19 Set First_sheet = Sheets("ف.1.أ") Set Second_sheet = Sheets("اللجنة") Mal_Femal$ = Second_sheet.Cells(1, 7) For I = 4 To 300 Step Position If Second_sheet.Cells(I - 1, 2) = "" Then Exit For Second_sheet.Cells(I, 2).Resize(15, 3).ClearContents Next If Mal_Femal = "" Then Exit Sub last_Clas = First_sheet.Cells(Rows.count, 2).End(3).Row Set find_rg = First_sheet.Rows(4).Find(Second_sheet.Cells(1, 6), lookat:=1) If find_rg Is Nothing Then Exit Sub col = find_rg.Column + 8 Mou3addaL = Val(First_sheet.Cells(8, col)) / 2 m = 4: k = 1 For I = 10 To last_Clas If First_sheet.Cells(I, col) < Mou3addaL And _ First_sheet.Cells(I, 4) = Mal_Femal Then If m Mod 19 = 0 Then m = m + 4: k = 1 With Second_sheet.Cells(m, 2) .Value = k .Offset(, 1) = First_sheet.Cells(I, 3) .Offset(, 2) = First_sheet.Cells(I, 6) End With m = m + 1: k = k + 1 End If Next Application.EnableEvents = True End Sub الملف نموذجي مرفق Ligann.xlsm

في نهاية الكود قبل End Sub هذا السطر With P Union(.[G7], .[C4], .[C8], .[H8], .[C9]) = vbNullString End With

جرب هذا الماكرو Option Explicit Sub Tarheel() Dim Mon_ARray(4) Dim ro%, X_C%, X_H%, Dr% Dim D As Worksheet, P As Worksheet Set P = Sheets("Permession") Set D = Sheets("Data") With P Mon_ARray(0) = .[G7]: Mon_ARray(1) = .[C4] Mon_ARray(2) = .[C8]: Mon_ARray(3) = .[H8] Mon_ARray(4) = .[C9] End With With D Dr = Application.Max(.Range("a:a")) + 1 ro = .Range("A3").CurrentRegion _ .Columns(1).Rows.Count + 3 .Cells(ro, 1) = Dr .Cells(ro, 1).Resize(, 11).Interior.ColorIndex = 35 .Cells(ro, 2).Resize(, UBound(Mon_ARray) + 1) = _ Mon_ARray Erase Mon_ARray End With X_C = Application.CountA(P.Range("C12:C18")) X_H = Application.CountA(P.Range("H12:H18")) D.Cells(ro, "H").Resize(X_C, 2).Value = _ P.Range("B12").Resize(X_C, 2).Value D.Cells(ro, "J").Resize(X_H, 2).Value = _ P.Range("G12").Resize(X_H, 2).Value End Sub الملف مرفق rouk.xlsm

الكود الثّاني Option Explicit Dim i%, Max_ro%, m% Dim J As Worksheet Dim ro%, col%, my_sum# Dim Spes_sh As Worksheet Dim D1 As Date, D2 As Date '+++++++++++++++++++++++++++++++++++ Sub Fil_data_All() Application.ScreenUpdating = False Set J = Sheets("Justify") J.Range("A5:O5000").Clear If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then MsgBox "Type Please a reel date in B2 and C2" GoTo Live_Me_PLease End If D1 = Application.Min(J.Range("B2"), J.Range("C2")) D2 = Application.Max(J.Range("B2"), J.Range("C2")) J.Range("B2") = D1: J.Range("C2") = D2 For Each Spes_sh In Sheets If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then Else Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row Spes_sh.Range("A2").Resize(Max_ro - 1, 16) _ .Interior.ColorIndex = 35 For col = 3 To 16 my_sum = 0 For ro = 2 To Max_ro If Spes_sh.Cells(ro, 1) <= D2 And _ Spes_sh.Cells(ro, 1) >= D1 Then Spes_sh.Cells(ro, 1).Interior.ColorIndex = 40 Spes_sh.Cells(ro, col).Interior.ColorIndex = 40 my_sum = my_sum + Val(Spes_sh.Cells(ro, col)) End If Next ro ro = J.Cells(Rows.Count, "O").End(3).Row m = IIf(ro <= 3, 5, ro + 1) J.Cells(m, col - 1) = my_sum J.Cells(m, 1) = Spes_sh.Name Next col End If Next Spes_sh If m > 5 Then J.Cells(m + 1, 1) = "SUM" J.Cells(m + 1, 2).Resize(, 14).Formula = _ "=SUM(B5:B" & m & ")" J.Cells(5, "O").Resize(m - 4).Formula = _ "=SUM(B5:N5)" With J.Cells(5, 1).Resize(m - 3, 15) .HorizontalAlignment = xlCenter .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True .Value = .Value .InsertIndent 1 End With J.Cells(m + 1, 1).Resize(, 15).Interior.ColorIndex = 40 End If Live_Me_PLease: Application.ScreenUpdating = True End Sub

انت طلبت التعديل على هذا الماكرو فقط

خلاص بفى احر مناقشة بهذا الموضوع الكود بعد التعديل Option Explicit Dim i%, Max_ro%, K%, m%, All_rows% Dim J As Worksheet Dim Spes_sh As Worksheet Dim D1 As Date, D2 As Date Dim x As Boolean '+++++++++++++++++++++++++++++++++++ Sub Fil_data() Application.ScreenUpdating = False Dim t%, cont%, n% m = 5: t = 5 Set J = Sheets("Justify") All_rows = J.Cells(Rows.Count, 1).End(3).Row If All_rows > 4 Then J.Range("A5:O" & All_rows + 5).Clear End If If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then MsgBox "Type Please a reel date in B2 and C2" GoTo Buy_Buy_Ya_Helween End If D1 = Application.Min(J.Range("B2"), J.Range("C2")) D2 = Application.Max(J.Range("B2"), J.Range("C2")) J.Range("B2") = D1: J.Range("C2") = D2 For Each Spes_sh In Sheets If Spes_sh.Name = "Tarhil" Or Spes_sh.Name = "Justify" Then Else Max_ro = Spes_sh.Cells(Rows.Count, 2).End(3).Row If Max_ro = 1 Then GoTo Next_SHeeet For K = 2 To Max_ro If Spes_sh.Cells(K, 1) <= D2 _ And Spes_sh.Cells(K, 1) >= D1 Then J.Cells(m, 2).Resize(, 14).Value = _ Spes_sh.Cells(K, 3).Resize(, 14).Value If Not x Then J.Cells(m, 1) = Spes_sh.Name End If x = True m = m + 1 End If Next K End If x = False Next_SHeeet: If Spes_sh.Name = "Tarhil" Or _ Spes_sh.Name = "Justify" Then Else J.Cells(m, 1) = "Sum" J.Cells(m, 2).Resize(, 14).Formula = _ "=SUM(B" & t & ":B" & m - 1 & ")" m = m + 1 t = m End If x = False Next Spes_sh If m > 5 Then For cont = 5 To m - 1 If J.Cells(cont, 1) = "Sum" Then J.Cells(cont, 1).Resize(, 15). _ Interior.ColorIndex = 35 End If Next cont J.Cells(m, 1) = "Sum Of ALL" J.Cells(m, 2).Resize(, 14).Formula = _ "=SUM(B5:B" & m - 1 & ")/2" J.Cells(m, 1).Resize(, 15).Interior.ColorIndex = 40 With J.Cells(5, 1).Resize(m - 4, 15) .HorizontalAlignment = xlCenter .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True .Value = .Value .InsertIndent 1 End With End If Buy_Buy_Ya_Helween: Application.ScreenUpdating = True End Sub الملف مرفق Om_Hamz_Super.xlsm