سليم حاصبيا

في الخلية (N3) هذه المعادلة واسجب عامودين و 7 أعمدة =SUMPRODUCT(--($H$3:$H$53<>""),--($H$3:$H$53<=$M3),--($H$3:$H$53>=$L3),--($I$3:$I$53=N$2)) الملف مرفق Mustafa.xlsx

لا يمكن عمل هذا لأن الاكسل لا يعرف ماذا تكتب في الخلايا هو صعب أوي الضغط على الزر؟؟؟؟

حرب هذا الملف jakord.xlsm

جرب هذا الملف 1- دبناميكي اي انه بضيف اسم الشيت المستجدثة او توماتيكياً الى القائمة المنتسدلة (الخلية الصفراء) (في حال اضافة شيت جديد) 2-قم بتسمية الأوراق حسب اسم الطالب الذي تحتويه كما في الصورة المرفقة 3- تم التعديل على المعادلات كي لا يكون هناك أخظاء قي حال كتابة قيمة ليست رقماً في اي خلية (الصورة) 4- كان يجب تعبئة الجداول ولا تترك هذا الشيء لمن يريد ان يساعدك 5- اختر من القائمة المنسدلة اسم الشيت ثم اضغط على الزر Run 6- الملف مرفق sohail.xlsm

ضعيها اينما تريدين

تصحيح الكود Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range Sub ADD_Sheets() Set T = Sheets("بيان") If T.AutoFilterMode Then T.Range("A8").AutoFilter Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 2 Then Exit Sub With T For i = 9 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("C" & i) & "'!A8)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("C" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets If Lr < 9 Then Exit Sub Set Flter_rg = T.Range("A8").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name = T.Name Or Spes_sh.Name = "Justify" Then Else Spes_sh.Range("A8").CurrentRegion.ClearContents Flter_rg.AutoFilter 3, Spes_sh.Name Flter_rg.SpecialCells(12).Copy Spes_sh.Range("A8").PasteSpecial (8) Spes_sh.Range("A8").PasteSpecial (xlPasteAll) End If Next If T.AutoFilterMode Then T.Range("A8").AutoFilter T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub Yasser_Filter.xlsm

1-اكتب ما تريد داحل الخلية C3 و ترى انها لا تأخذ الا القيمة القديمة وتضيف 2 2- أكبر عدد تريد الوصول اليه اكتبه في الخلية F2 3-اذا وضعت في الخلية F2 نص او تركتها فارغة او عدد سالب فأن الافتراضي فيها هو 50 (اي اتها تأخذ القيمة 50 اوتوماتيكياً) 4- بعد ان تتجاوز قيمة الحلية C3 العدد الموجود في F2 تعود الى 1 Odd_Numbering.xlsm

التقريب للأعلى =CEILING(SUM($L7,$K7/100)*$M$5,0.1) التقريب للاسفل =FLOOR(SUM($L7,$K7/100)*$M$5,0.1) Samah.xlsb

الكود بتعامل مع اي عدد من الطلاب يمكنك اضافة ما تريد من اسماء

تم عمل المطلوب كما تريدين 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:L5000").Clear If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then MsgBox "Type Please a reel date in B2 and C2" Exit Sub 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, 11) _ .Interior.ColorIndex = 35 For col = 3 To 11 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, "j").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(, 9).Formula = _ "=SUM(B5:B" & m & ")" J.Cells(5, "J").Resize(m - 4).Formula = _ "=SUM(B5:I5)" With J.Cells(5, 1).Resize(m - 3, 10) .HorizontalAlignment = xlCenter .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True .Value = .Value .InsertIndent 1 End With J.Cells(m + 1, 1).Resize(, 10).Interior.ColorIndex = 40 End If Application.ScreenUpdating = True End Sub الملف مرفق (الكود القديم ما زال يعمل اذا كانت هناك حاجة اليه) Om_Hamz_Matloub.xlsm

وبرده على اساس اسم الشيت الى هو اسم الحساب هذه لم افهمها

وتجميع البيانات بالتاريخ من الى تاريخ كان يجب طلب هذا الشيء من البداية لا أضاعة لمزيد من الوقت 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() 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:L" & 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" Exit Sub 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(, 11).Value = _ Spes_sh.Cells(K, 1).Resize(, 11).Value If Not x Then Else J.Cells(m, 3) = "" End If x = True m = m + 1 End If Next K End If Next_SHeeet: If Spes_sh.Name = "Tarhil" Or _ Spes_sh.Name = "Justify" Then Else J.Cells(m, 2) = "Sum" J.Cells(m, 4).Resize(, 9).Formula = _ "=SUM(D" & t & ":D" & 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, 2) <> "Sum" Then J.Cells(cont, 1) = n + 1 n = n + 1 Else J.Cells(cont, 1).Resize(, 12). _ Interior.ColorIndex = 35 End If Next cont With J.Cells(5, 1).Resize(m - 5, 12) .HorizontalAlignment = xlCenter .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True .Value = .Value .InsertIndent 1 End With For cont = 5 To m - 1 If J.Cells(cont, 2) = "Sum" Then With J.Cells(cont, 2).Resize(, 2) .Merge .HorizontalAlignment = 3 End With End If Next cont End If End Sub الملف لآخر مرّة و سوف أغلق الموضوع بعد الأجابة مباشرة (لا مزيد من الأسئلة) OM_HAMZA_WITH_SUMMATION.xlsm

تم معالجة الأمر البيانات المكررة في اي شيت يقوم الماكرو بادراحها مرة واحدة فقط بمعنى اخر لو تم الضغط على الزر اكثر من مرة (دون التعديل في البيانات Tarhil) لا تتكرر البيانات Option Explicit Dim i%, Max_ro%, K%, m% Dim J As Worksheet Dim Spes_sh As Worksheet Dim D1 As Date, D2 As Date '+++++++++++++++++++++++++++++++++++ Sub Fil_data() Set J = Sheets("Justify") J.Range("A5").CurrentRegion.Clear If Not IsDate(J.Range("B2")) Or Not IsDate(J.Range("C2")) Then MsgBox "Type Please a reel date in B2 and C2" Exit Sub 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 m = 5 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, 1) = m - 4 J.Cells(m, 2).Resize(, 11).Value = _ Spes_sh.Cells(K, 1).Resize(, 11).Value m = m + 1 End If Next K End If Next_SHeeet: Next Spes_sh If m > 5 Then With J.Cells(5, 1).Resize(m - 5, 12) .HorizontalAlignment = xlCenter .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True .Value = .Value .InsertIndent 1 End With End If End Sub الملف من جديد OM_HAMZA_SHEETS_NEW.xlsm

تغيير اسماء الصفحات الى الأجنبية لحسن عمل الكود و نسخه Option Explicit Dim i%, Lr% Dim T As Worksheet Dim Spes_sh As Worksheet Dim Flter_rg As Range '+++++++++++++++++++++++++++ Sub ADD_Sheets() Set T = Sheets("Tarhil") Lr = T.Cells(Rows.Count, 2).End(3).Row If Lr < 2 Then Exit Sub With T For i = 2 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("B" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("B" & i) End If Next End With End Sub '+++++++++++++++++++++++++++ Sub transfer_data() Application.ScreenUpdating = False ADD_Sheets If Lr < 2 Then Exit Sub Set Flter_rg = T.Range("A1").CurrentRegion For Each Spes_sh In Sheets If Spes_sh.Name = T.Name Or Spes_sh.Name = "Justify" Then Else Spes_sh.Range("A1").CurrentRegion.ClearContents Flter_rg.AutoFilter 2, Spes_sh.Name Flter_rg.SpecialCells(12).Copy Spes_sh.Range("A1").PasteSpecial (12) End If Next If T.AutoFilterMode Then T.Range("A1").AutoFilter T.Select With Application .ScreenUpdating = True .CutCopyMode = False End With End Sub الملف مرفق OM_HAMZA_SHEETS.xlsm

لا تفتج اي شيت لان ActiveSheet يفتجة اوتومانيكياً

اضف هذه العبارة داخل المربع الأزرق كي نغرف في اي شيب ينم العمل MsgBox ActiveSheet.Name

هو كذلك اذا لم يكن هنالك اخطاء اخرى في حال ظهور اخطاء اقفل الملف دون Save

قم بهذه التجربة استبدال ما في المربع الأحمر بما في المربع الأزرق اينما تجدها( داخل كل الأكواد) كما في الصورة

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

صديقى تم الرد على سؤالك بالاجابة اته لا يمكن لأحد ان يضع لك 50 كود لاكثر من 50 تكست بوكس لو كل كود اخذ 10 دقائق لوضعه (كي لا اقول أكثر) المسألة يلزمها 8 ساعات

صممت لك كود لأخضر والأحمر R_G (على اساس انه اخر سؤال) من أين اتى R_B ؟؟؟ ( لماذا اختلفت المعادلات عما ورد في الرسالة على الحاص؟؟) الكود للـــ R_G يمكنك تعديل المعادلات داخله كما نريدين (و سوف أغلق الموضوع لأنه اخذ اكثر يكثير من وقته) Option Explicit Sub get_By_Color() Dim D As Worksheet Dim Sh As Worksheet Dim Ar(), Min_date As Date, Max_date As Date Dim K%, t%, Arr_sh() Dim My_ro%, m%, ro%, my_sum#, x% Dim Sum_pos#, Sum_Neg# Dim Part_sum# K = 2 Set D = Sheets("DataReport") D.Rows.Hidden = False If D.Range("A3").CurrentRegion.Rows.Count > 1 Then D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear End If If Not IsDate(D.Range("J2")) Or _ Not IsDate(D.Range("K2")) Then Exit Sub Min_date = Application.Min(D.Range("J2:K2")) Max_date = Application.Max(D.Range("J2:K2")) Ar = Array("E", "F", "G", "H", "I", "J") 'For Each Sh In Sheets Select Case UCase(D.Range("N1")) Case 3, 10, 55 For Each Sh In Sheets If Sh.Tab.ColorIndex = D.Range("N1") Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_G" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "G_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case Else For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next End Select If m = 0 Then Exit Sub For m = LBound(Arr_sh) To UBound(Arr_sh) D.Cells(K, 1) = Arr_sh(m) D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J") D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20 K = K + 2 Next m My_ro = 3 For m = LBound(Arr_sh) To UBound(Arr_sh) Set Sh = Sheets(Arr_sh(m)) Sh.Range("A5:J20000").Interior.ColorIndex = xlNone ro = Sh.Cells(Rows.Count, 1).End(3).Row For K = LBound(Ar) To UBound(Ar) t = K + 2 For x = 5 To ro If Sh.Cells(x, 1) <= Max_date _ And Sh.Cells(x, 1) >= Min_date Then Sh.Cells(x, 1).Interior.ColorIndex = 40 If Val(Sh.Cells(x, Ar(K))) <> 0 Then my_sum = my_sum + Sh.Cells(x, Ar(K)) '+++++++++++++++++++++++++++++ If Val(Sh.Cells(x, Ar(K))) <= 0 Then Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6 Else Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35 End If '++++++++++++++++++++++++++ Part_sum = Round((Sum_pos * 0.85) + Sum_Neg, 2) End If '<>0 End If Next x '////////////////////////////// Select Case D.Cells(12, "J") Case "Positive" Select Case D.Range("N1") Case 3: Sum_pos = 0.1475 * Sum_pos Case 55: Sum_pos = 0.705 * Sum_pos '}}}}}}}}}}}}}}}}}}}}} Case "R_G" If Sh.Tab.ColorIndex = 3 Then Sum_pos = 0.1475 * Sum_pos ElseIf Sh.Tab.ColorIndex = 10 Then Sum_pos = 0.705 * Sum_pos Else Sum_pos = Sum_pos End If '}}}}}}}}}}}}}}}}}}}}} Case Else: Sum_pos = Sum_pos End Select D.Cells(My_ro, t) = Sum_pos Case "Nagative" D.Cells(My_ro, t) = Sum_Neg Case "Part" D.Cells(My_ro, t) = Part_sum Case Else D.Cells(My_ro, t) = my_sum End Select '////////////////////////////// my_sum = 0: Sum_pos = 0: Sum_Neg = 0: Part_sum = 0 Next K My_ro = My_ro + 2 Next m D.Cells(My_ro, 1) = "Sum Of All" Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar With D.Cells(My_ro - 1, 2).Resize(, 6) .Value = D.Cells(1, 2).Resize(, 6).Value .Interior.Color = vbBlue .Font.Color = vbWhite End With D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _ "=Sum(B3:B" & My_ro - 2 & ")" D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6 If D.Range("A3").CurrentRegion.Rows.Count > 1 Then With D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True: .HorizontalAlignment = xlCenter .Value = .Value End With End If For m = My_ro - 2 To 3 Step -1 If D.Cells(m, 1) Like "Total*" And _ Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True End If Next End Sub الصورة تظهر مكان التعدبل والملف مرفق (تم ازالة الزركشات بالألوان لتحجيم الملف الى 2.5 ميغا و مازال كبيراً ) Yara_super_More_Optione.xlsm

الكود الصحيح Private Sub Yh_TextFind_Change() Dim MySh As Worksheet Dim LastRow As Integer Dim M As String Dim A As Range, F% Set MySh = Sheets("ورقة1") Yh_ListFind.Clear If Yh_TextFind.Text = "" Then Exit Sub M = Yh_TextFind.Text LastRow = MySh.Cells(Rows.Count, 1).End(3).Row Set A = MySh.Range("F3:F" & LastRow).Find(M, LOOKAT:=1) If A Is Nothing Then Exit Sub F = A.Row Do With Yh_ListFind .AddItem For K = 0 To 9 .List(.ListCount - 1, K) = _ MySh.Cells(A.Row, K + 1) Next K End With Set A = MySh.Range("F3:F" & LastRow).FindNext(A) Loop While A.Row <> F End Sub YESS_w.xlsm

1-تصغير الملف الى 20 - 40 اسم لا أكثر تختار الأرقام من الخليتين B1 و B2 (في حال الخطأ الماكرو ياخذ الأرقام من 1 الى عدد الطلاب) 2- في حال تريد طالباً واحداَ تكرر رقمه في B1 و B2 مثلاً نريد الطالب رقم 5 نضع 5=B1 و 5=B2 يوجد صفحة مخفية لادراج الجداول (عدم المس بها لحسن سير عمل الماكرو) جرب خذا الملف Dim Mn%, Mx%, LR, k%, t%, i% Dim ValA, ValB Dim xx1%, xx2% '++++++++++++++++++++++++++++++++ Rem Created By Salim Hasbaya On 20/11/2020 Sub CopY_rg(rg As Range, Where%) rg.Copy Saf.Range("A" & Where).PasteSpecial (xlPasteAll) Application.CutCopyMode = False End Sub '++++++++++++++++++++++++++++++++ Sub fil_Rg() Rem Created By Salim Hasbaya On 20/11/2020 LR = Fat.Cells(Rows.Count, 3).End(3).Row If LR < 10 Then Exit Sub xx1 = Val(Fat.Range("B1")) xx2 = Val(Fat.Range("B2")) ValA = IIf(xx1 <= 0, 1, Int(xx1)) ValB = IIf(xx2 <= 0, LR - 9, Int(xx2)) If ValA > LR - 9 Then ValA = 1 If ValB > LR - 9 Then ValB = LR - 9 Mn = Application.Min(ValA, ValB) Mx = Application.Max(ValA, ValB) Fat.Range("B1") = Mn: Fat.Range("B2") = Mx t = Fat.Range("B2") - Fat.Range("B1") + 1 k = 1 Saf.Cells.Clear For i = 1 To t Call CopY_rg(Source.Range("SPES_RG"), k) k = k + 18 Next Saf.Rows.AutoFit End Sub '++++++++++++++++++++++++++++++++++ Sub Get_certificates() Rem Created By Salim Hasbaya On 20/11/2020 fil_Rg Dim Ro1%, Ro2%, Pos% Dim y%, n% Dim A1, A2, A3 A1 = Application.Transpose(Source.Range("Q1:AA1")) A1 = Application.Transpose(A1) A2 = Application.Transpose(Source.Range("Q2:AA2")) A2 = Application.Transpose(A2) A3 = Application.Transpose(Source.Range("Q3:AA3")) A3 = Application.Transpose(A3) Pos = 8 Ro1 = Fat.Range("B1") + 9 Ro2 = Fat.Range("B2") + 9 For y = Ro1 To Ro2 Saf.Cells(Pos - 6, 3) = Fat.Cells(y, 3) For n = LBound(A1) To UBound(A1) If Saf.Cells(Pos, 1) = "" Then Exit For Saf.Cells(Pos, 3).Offset(, n - 1) = _ Fat.Cells(y, A1(n)) Saf.Cells(Pos, 3).Offset(1, n - 1) = _ Fat.Cells(y, A2(n)) Saf.Cells(Pos, 3).Offset(2, n - 1) = _ Fat.Cells(y, A3(n)) Next n Pos = Pos + 18 Next y Saf.PageSetup.PrintArea = Saf.Range("a1") _ .Resize(Pos - 10, 14).Address End Sub Khiri.xlsm

أضافة ماكرو جديد (نفس القديم مع زيادة ما في هذه الصورة) و زر جديد له More Options الملف اصبج بحجم كبير جداً (حوالي 9 ميغا لا يطاق) ما كفاية بقى بحث بهذا الموضوع الذي ضجرنا منه رغبة في مزاجية رب عملك (كل ساعة يلون) سوف يتم اغلاق الموضوع مباشرة بعد الحصول على رد لهذه الاجابة Option Explicit Sub get_By_Color() Dim D As Worksheet Dim Sh As Worksheet Dim Ar(), Min_date As Date, Max_date As Date Dim K%, t%, Arr_sh() Dim My_ro%, m%, ro%, my_sum#, x% Dim Sum_pos#, Sum_Neg# Dim Part_sum# K = 2 Set D = Sheets("DataReport") D.Rows.Hidden = False If D.Range("A3").CurrentRegion.Rows.Count > 1 Then D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear End If If Not IsDate(D.Range("J2")) Or _ Not IsDate(D.Range("K2")) Then Exit Sub Min_date = Application.Min(D.Range("J2:K2")) Max_date = Application.Max(D.Range("J2:K2")) Ar = Array("E", "F", "G", "H", "I", "J") 'For Each Sh In Sheets Select Case UCase(D.Range("N1")) Case 3, 10, 55 For Each Sh In Sheets If Sh.Tab.ColorIndex = D.Range("N1") Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "R_G" For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case "G_B" For Each Sh In Sheets If Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Case Else For Each Sh In Sheets If Sh.Tab.ColorIndex = 3 _ Or Sh.Tab.ColorIndex = 10 _ Or Sh.Tab.ColorIndex = 55 Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next End Select If m = 0 Then Exit Sub For m = LBound(Arr_sh) To UBound(Arr_sh) D.Cells(K, 1) = Arr_sh(m) D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J") D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20 K = K + 2 Next m My_ro = 3 For m = LBound(Arr_sh) To UBound(Arr_sh) Set Sh = Sheets(Arr_sh(m)) Sh.Range("A5:J20000").Interior.ColorIndex = xlNone ro = Sh.Cells(Rows.Count, 1).End(3).Row For K = LBound(Ar) To UBound(Ar) t = K + 2 For x = 5 To ro If Sh.Cells(x, 1) <= Max_date _ And Sh.Cells(x, 1) >= Min_date Then Sh.Cells(x, 1).Interior.ColorIndex = 40 If Val(Sh.Cells(x, Ar(K))) <> 0 Then my_sum = my_sum + Sh.Cells(x, Ar(K)) '+++++++++++++++++++++++++++++ If Val(Sh.Cells(x, Ar(K))) <= 0 Then Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6 Else Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35 End If '++++++++++++++++++++++++++ Part_sum = Round((Sum_pos * 0.85) + Sum_Neg, 2) End If '<>0 End If Next x Select Case D.Cells(12, "J") Case "Positive" Select Case D.Range("N1") Case 3: Sum_pos = 0.1475 * Sum_pos Case 55: Sum_pos = 0.705 * Sum_pos Case Else: Sum_pos = Sum_pos End Select D.Cells(My_ro, t) = Sum_pos Case "Nagative" D.Cells(My_ro, t) = Sum_Neg Case "Part" D.Cells(My_ro, t) = Part_sum Case Else D.Cells(My_ro, t) = my_sum End Select my_sum = 0: Sum_pos = 0: Sum_Neg = 0: Part_sum = 0 Next K My_ro = My_ro + 2 Next m D.Cells(My_ro, 1) = "Sum Of All" Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar With D.Cells(My_ro - 1, 2).Resize(, 6) .Value = D.Cells(1, 2).Resize(, 6).Value .Interior.Color = vbBlue .Font.Color = vbWhite End With D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _ "=Sum(B3:B" & My_ro - 2 & ")" D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6 If D.Range("A3").CurrentRegion.Rows.Count > 1 Then With D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True: .HorizontalAlignment = xlCenter .Value = .Value End With End If For m = My_ro - 2 To 3 Step -1 If D.Cells(m, 1) Like "Total*" And _ Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True End If Next End Sub الملف مرفق Yara_More_Optione.xlsm

بالنسبة للموضوع الأول هناك اشياء موصوعة الــ "GB" أظن "Gega byte" و أشياء موضوعة بالـــ "TB" "Terra Byte" في هذا الكود يتم الجمع على اساس الــ "GB" كل "TB" = مليون "GB" حسب نا أغتقد اذا كان خطأ استبدل في الماكرو الرقم مليون (Const Multp) الى الرقم الذي تعتقده صحيحاً الكود لهذا الأمر يتم التنفيذ في العامود (F) Option Explicit Sub test_For_TB() '+++++++++++++++++++++ Dim ws As Worksheet Dim ro%, Sm#, Big_Sm#, x%, k% Dim My_sum#, Big_sum# Dim arr Const Multp = 1000000 '++++++++++++++++++++++ Set ws = Worksheets("Salim") ro = ws.Cells(Rows.Count, 2).End(3).Row ws.Cells(2, 6).CurrentRegion.Clear For x = 2 To ro arr = Replace(ws.Range("b" & x), Chr(32), " ") arr = Replace(arr, Chr(10), " ") arr = Split(arr, " ") For k = 0 To UBound(arr) - 1 Step 2 If UCase(arr(k + 1)) = "TB" Then Sm = Sm + arr(k) * Multp Else Sm = Sm + arr(k) * 1 End If Next k Big_Sm = Big_Sm + Sm ws.Range("F" & x) = Sm Sm = 0 Next x Range("F" & ro + 1) = Big_Sm With ws.Range("F2").Resize(ro) .HorizontalAlignment = 3 .VerticalAlignment = 2 .Borders.LineStyle = 1 .Font.Bold = True .NumberFormat = "#,##0" End With End Sub الملف من جديد مع الكود الجديد والقديم بنفس الوقت ahmed_atoon_TB.xlsm