سليم حاصبيا

تم معالجة الأمر البحث يتم بواسطة الرقم لا بالتاريخ (لضيق الوقت ) يمكنك التعديل اذا اردت البحث بالتاريخ Number_search.xlsm

يمكنك استعمال هذا الماكرو ايضاُ (اذا كان الأمر يتعلق بخلية واحدة الماكرو الأول او عدة خلايا(نطاق) الماكرو الثاني Sub wrap_cel() Range("d1").WrapText = True End Sub '+++++++++++++++++++++++++++++++++ Sub wrap_range() Range("A1:C410").WrapText = True End Sub

هذا الكود البسيط (استبدل الرقم 3 بالرقم الي تريده) Sub Wrap_col() Columns(3).AutoFit End Sub

كل المعادلات عادية (بدون CTRL+SHIFT+ENTER) اذا اردت ان يكون تاريخ البداية والنهاية ضمن المجموع =SUMPRODUCT(($D$4:$D$13<=$I$4)*($D$4:$D$13>=$G$4)) اذا اردت ان لا يكونا ضمن المجموع =SUMPRODUCT(($D$4:$D$13<$I$4)*($D$4:$D$13>$G$4)) اذا اردت ان يكون احدهما ضمن الموحوع ( الأصغر فقط أو الأكبر فقط) =SUMPRODUCT(($D$4:$D$13<=$I$4)*($D$4:$D$13>$G$4))

ممكن ان يكون المطلوب Tawati.xlsm

لا يمكن اخفاء خلية أو مجموعة خلايا يمكن فقط اخفاء عامود أو عدة اعمدة صف أو عدة صفوف

جرب هذا الكود Private Sub CommandButton2_Click() On Error Resume Next Range("a9").Resize(9).SpecialCells(4) _ .EntireRow.Delete Shift:=xlUp End Sub

جرب هذا الملف لنسخ اي خلية 1- حدد الخلية 2- Crtl+C 3- حدد الخلية الهدف 4- Ctrl+V Protect_with_copy.xlsm

لا داعي لاي شيء فقط قم باخفاء الأعمدة التي لا تريدها مستعملاً هذا الماكرو Sub Hide_columns() Dim k% Sheets("Infos").Columns.Hidden = False Dim arr() arr = Array(3, 4, 5, 6, 7, 8, 9, 10) For k = LBound(arr) To UBound(arr) Sheets("Infos").Columns(arr(k)).Hidden = True Next End Sub في الصورة المرفقة حدد أرقام الأعمدة التي تريد اخفا ئها من خلال Array (تسلسل الأرقام داخل Array غير ضروري) Information_Advanced_Ar_date_1.xlsm

تقضل Information_Advanced_Ar_date.xlsm

تم التعديل اذا كان الرقم وحيداً يكتب بالعربية واذا كان مصحوباً مع اي شيء اخر اكسل يتعبره نصاّ لذلك لا يدرجه بالعربية Information_Advanced_Ar.xlsm

تم التعديل على الكود كما تريد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then If Target = vbNullString Then Find_Hawiyya_ALL Else Find_Hawiyya End If End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++ Sub Find_Hawiyya() Dim Inf As Worksheet, Act_sh As Worksheet Dim s_rg As Range, find_rg As Range Dim Inf_rg As Range Dim Targ_rg As Range Dim Where_rg As Range Dim m%, Ro%, x%, N% Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") N = Sheets.Count m = 8 Set Inf_rg = Inf.Range("A7").CurrentRegion Inf.Cells(2, 2) = vbNullString If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear 'If s_rg = vbNullString Then Exit Sub For x = 1 To N If Sheets(x).Name = Inf.Name Then GoTo Next_x Set Act_sh = Sheets(x) Set find_rg = Sheets(x).Range("D:D") Set Targ_rg = find_rg.Find(s_rg, Lookat:=1) If Not Targ_rg Is Nothing Then Ro = Targ_rg.Row Inf.Cells(m, 2).Resize(, 18).Value = _ Sheets(x).Cells(Ro, 2).Resize(, 18).Value Inf.Cells(m, 1) = m - 7 m = m + 1 End If Next_x: Next x If m = 8 Then MsgBox "No Data To Exract": Exit Sub Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 19 End With Inf.Cells(2, 2) = Inf.Cells(8, "E") End Sub '++++++++++++++++++++++++++++++++++++ Sub Find_Hawiyya_ALL() Dim Inf As Worksheet Dim s_rg As Range Dim Inf_rg As Range Dim Where_rg As Range Dim m%, t%, x% Dim Dic As Object, ky Dim arr(11) Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") Set Dic = CreateObject("Scripting.Dictionary") '============================ Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear For t = 1 To 12: arr(t - 1) = t & "": Next m = 8 '======================= If s_rg <> vbNullString Then Exit Sub For x = 1 To Sheets.Count If IsError(Application.Match(Sheets(x).Name, arr, 0)) Then _ GoTo Next_x Set Where_rg = Sheets(x).Range("a1").CurrentRegion If Where_rg.Rows.Count = 1 Then GoTo Next_x Set Where_rg = Where_rg.Offset(1).Resize(Where_rg.Rows.Count - 1) For t = 1 To Where_rg.Rows.Count Dic.Add (t - 1), Where_rg. _ Rows(t).Cells(2).Resize(, 18).Value Next t For Each ky In Dic.keys Inf.Cells(m, 2).Resize(, 18) = Dic(ky) Inf.Cells(m, 1) = m - 7 m = m + 1 Next ky Next_x: Dic.RemoveAll Next x Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 35 End With Inf.Cells(2, 2) = "ALL" End Sub الملف مرفق Information_Advanced.xlsm

جرب هذا الكود تسمية الورقة الأولى باسم "Infos" لسهولة نسخ الكود ولصقه دون مشاكل اللغة Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And Target.Count = 1 Then Find_Hawiyya End If Application.EnableEvents = True End Sub '+++++++++++++++++++++++++++++ Sub Find_Hawiyya() Dim Inf As Worksheet, Act_sh As Worksheet Dim s_rg As Range, find_rg As Range Dim Inf_rg As Range Dim Targ_rg As Range Dim Where_rg As Range Dim m%, Ro%, x%, N% Set Inf = Sheets("Infos") Set s_rg = Inf.Range("A2") N = Sheets.Count m = 8 Set Inf_rg = Inf.Range("A7").CurrentRegion Inf.Cells(2, 2) = vbNullString If Inf_rg.Rows.Count > 1 Then _ Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear If s_rg = vbNullString Then Exit Sub For x = 1 To N If Sheets(x).Name = Inf.Name Then GoTo Next_x Set Act_sh = Sheets(x) Set find_rg = Sheets(x).Range("D:D") Set Targ_rg = find_rg.Find(s_rg, Lookat:=1) If Not Targ_rg Is Nothing Then Ro = Targ_rg.Row Inf.Cells(m, 2).Resize(, 18).Value = _ Sheets(x).Cells(Ro, 2).Resize(, 18).Value Inf.Cells(m, 1) = m - 7 m = m + 1 End If Next_x: Next x If m = 8 Then MsgBox "No Data To Exract": Exit Sub Set Inf_rg = Inf.Range("A7").CurrentRegion If Inf_rg.Rows.Count = 1 Then Exit Sub With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1) .Borders.LineStyle = 1: .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .Interior.ColorIndex = 19 End With Inf.Cells(2, 2) = Inf.Cells(8, "E") End Sub الملف مرغف Infomation.xlsm

الآن فهمت عليك ماذا تريد (كي لا تظهر الاصفار في اي خلية ) بدون فورمات سيلس استبدل هذا السطر في الكود R.Cells(k, y).Value = My_sum: My_sum = 0 الى R.Cells(k, y).Value = IIf(My_sum = 0, "", My_sum): My_sum = 0

تصحيح Option Explicit Sub Trasfer_data_Special() Dim R As Worksheet, Act_sh As Worksheet Dim k%, col%, Ro% Dim Max_ro%, x%, y% Dim Bol As Boolean Dim ST_Dat As Date Dim End_Dat As Date Dim My_sum# Dim Mot$ Mot = "الاجمالى" Set R = Sheets("Report_Youmi") Ro = R.Cells(Rows.Count, 1).End(3).Row R.Range("C3").CurrentRegion.Resize(Ro - 1).ClearContents R.Cells(3, 9).Resize(Ro - 2).ClearContents ST_Dat = Application.Min(R.Range("I2:J2")) End_Dat = Application.Max(R.Range("I2:J2")) For k = 3 To Ro - 2 Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") If Bol Then Set Act_sh = Sheets(R.Range("A" & k) & "") Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row For y = 3 To 7 For x = 5 To Max_ro If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat And _ Act_sh.Cells(x, 2) <> Mot Then My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _ Act_sh.Cells(x, y + 2), 0) End If Next x R.Cells(k, y).Value = IIf(My_sum = 0, "", My_sum): My_sum = 0 Next y End If Next k '+++++++++++++++++++++++++++++++++ R.Cells(Ro - 1, 3).Resize(, 5).Formula = _ "=if(COUNT(C$4:C$39)>0,SUM(C$4:C$39),"""")" R.Cells(Ro, 3).Resize(, 5).Formula = _ "=IF(COUNT(C$7:C$17)>0,SUM(C$7:C$17),"""")" R.Cells(4, 9).Resize(Ro - 3).Formula = _ "=IF(COUNT($C4:$G4)>0,SUM($C4:$G4),"""")" R.Range("A3:I" & Ro).Value = _ R.Range("A3:I" & Ro).Value End Sub

الموضوع اخذ من الوقت اكثر مما يحتاحه أرجو ان يكون أخر سؤال الكود لعدم ادراج اصفار Option Explicit Sub Trasfer_data_Special() Dim R As Worksheet, Act_sh As Worksheet Dim k%, col%, Ro% Dim Max_ro%, x%, y% Dim Bol As Boolean Dim ST_Dat As Date Dim End_Dat As Date Dim My_sum# Dim Mot$ Mot = "الاجمالى" Set R = Sheets("Report_Youmi") Ro = R.Cells(Rows.Count, 1).End(3).Row R.Range("C3").CurrentRegion.Resize(Ro - 1).ClearContents R.Cells(3, 9).Resize(Ro - 2).ClearContents ST_Dat = Application.Min(R.Range("I2:J2")) End_Dat = Application.Max(R.Range("I2:J2")) For k = 3 To Ro - 2 Bol = Application.Evaluate _ ("ISREF('" & R.Range("A" & k) & "'!A1)") If Bol Then Set Act_sh = Sheets(R.Range("A" & k) & "") Max_ro = Act_sh.Cells(Rows.Count, 1).End(3).Row For y = 3 To 7 For x = 5 To Max_ro If CDate(Act_sh.Cells(x, 1)) >= ST_Dat And _ CDate(Act_sh.Cells(x, 1)) <= End_Dat And _ Act_sh.Cells(x, 2) <> Mot Then My_sum = My_sum + IIf(IsNumeric(Act_sh.Cells(x, y + 2)), _ Act_sh.Cells(x, y + 2), 0) End If Next x R.Cells(k, y).Value = My_sum: My_sum = 0 Next y End If Next k '+++++++++++++++++++++++++++++++++ R.Cells(Ro - 1, 3).Resize(, 5).Formula = _ "=Sum(C$4:C$" & Ro - 2 & ")" R.Cells(Ro, 3).Resize(, 5).Formula = _ "=Sum(C$7:C$17)" R.Cells(4, 9).Resize(Ro - 3).Formula = _ "=IF(COUNTA($C4:$G4)>0,SUM($C4:$G4),"""")" R.Range("A3:I" & Ro).Value = _ R.Range("A3:I" & Ro).Value End Sub

استبدل هذا السطر R.Cells(Ro, 9) = "Global Sum" بهذا R.Cells(Ro, 9).Formula = _ "=SUM(C" & Ro & ":G" & Ro & ")"

فتش على هذه الكلمة داخل الكود واستبدلها بما تريد انا صراحة لا أحب الكتابة باللغة العربية داخل الكود

تم معالجة الامر My_Repport_Updated.xlsm

من قال لك ان تزيل هذا العامود الفارغ مم يسبب في اشكال في الكود

غير هذه السطور في الكود R.Cells(Ro + 1, 3).Resize(, 5).Formula = _ "=Sum(C$3:C$" & Ro - 2 & ")" R.Cells(3, 9).Resize(Ro - 1).Formula = _ "=IF(COUNTA($C3:$G3)>0,SUM($C3:$G3),"""")" الى R.Cells(Ro + 1, 3).Resize(, 5).Formula = _ "=Sum(C$4:C$" & Ro - 2 & ")" R.Cells(4, 9).Resize(Ro - 2).Formula = _ "=IF(COUNTA($C4:$G4)>0,SUM($C4:$G4),"""")"

تم معالجة الأمر الشيت "شيت تبيض الدور الأول" يمكن اخفائها اذا اردت أم يمكن حذفها نهائياً لكن Sheet1 لا يمكن الاستغناء عنها لأنها تحتفظ بالديباجة اذا زاد او نقص عدد الطلاب يمكن ازالة الديباجات بواسطة الماكرو المخصص لهذه الغاية (الزر Del Dibaja ) تم التعديل على البيانات (دون صفوف فارغة) و من ثم تقسيم الديباجات على الصفحة حسب الرقم الذي تريده من الــ Input Box الكود الجديد Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box, ro% If ActiveSheet.Name <> "Salim" Then GoTo End_Me Application.ScreenUpdating = False del_Empty_rows In_box = Application.InputBox("How Many Rows", , 20) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 7 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 lr = Cells(Rows.Count, 2).End(3).Row On Error Resume Next On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Sheets("sheet1").Range("My_DEB").Copy _ Cells(t, 1) t = t + a + z + 1 Loop ro = ActiveSheet.Cells(Rows.Count, 2).End(3).Row Rows(ro + 1).Resize(z).Insert Sheets("sheet1").Range("My_DEB").Copy _ Cells(ro + 1, 1) End_Me: Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++ Sub del_Empty_rows() On Error Resume Next Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row Range("B" & lr + 1).Resize(20).EntireRow.Delete Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete On Error GoTo 0 End Sub الملف من جديد Najehoun.xlsm_2.xlsm

بالنسبة للصق (يمكنك الاختيار من خلال الـــ Input Box عدد الصفوف في كل مرة والافتراضي هو 20 لذلك اذا اردت اكثر أو اقل حدد بنفسك واضغط Ok) تم ادراج شيت جديد يحتوي على الديباجة (الشيت مخفية لأن لا عمل لها سوى الاحتفاظ بالديباجة) لأ انه في حال مسح المعلومات لادراج رقم جديد للصفوف تم تمسح ألديباجة الملف الجديد مرفق (بردو الصفحة Salim من هذا الملف لأني لا اريد ان أغير شيئاً بالشيت الأولى حفاظاَ على محتوياتها) الزر Del Dibaja هو لارجاع البيانات الأصلية كما كانت بدون ديباجات الماكرو الجديد Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box If ActiveSheet.Name <> "Salim" Then GoTo End_Me Application.ScreenUpdating = False del_Empty_rows In_box = Application.InputBox("How Many Rows", , 20) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 7 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 lr = Cells(Rows.Count, 2).End(3).Row On Error Resume Next Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4) my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Sheets("sheet1").Range("My_DEB").Copy _ Cells(t, 1) t = t + a + z + 1 Loop End_Me: Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++ Sub del_Empty_rows() On Error Resume Next Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete On Error GoTo 0 End Sub الملف من جديد Najehoun.xlsm_1.xlsm

لم ار الأعجاب على اخر مشاركة حتى الآن

حرب هذا الكود ( DIBAJA هي النطاق الذي يحتوي على الديباجة من B1 الى AZ4 ) كان الأفضل عدم ادراج علة العلل بالنسبة للأكواد والمعادلات وهي الخلايا المدمجة صفحة salim من هذا الملف Sub salim_rows() Dim t%, lr%, x%, z%, a% Dim my_rg As Range, k% Dim In_box If ActiveSheet.Name <> "Salim" Then GoTo End_Me Application.ScreenUpdating = False del_Empty_rows In_box = Application.InputBox("How Many Rows", , 20) a = In_box - 1 'number of rows for every group z = 3 'number of rows to be insert every time x = 7 'first row to begine If a <= 0 Then Exit Sub t = x + a + 1 If z > 5 Then z = 5 lr = Cells(Rows.Count, 2).End(3).Row On Error Resume Next Set my_rg = Range("B" & x & ":B" & lr).SpecialCells(4) my_rg.EntireRow.Delete On Error GoTo 0 Do Until Cells(t, "B") = "" Rows(t).Resize(z).Insert Range("DIBAJA").Copy _ Cells(t, 1) t = t + a + z + 1 Loop End_Me: Application.ScreenUpdating = True End Sub '++++++++++++++++++++++++++++ Sub del_Empty_rows() On Error Resume Next Dim lr%: lr = Cells(Rows.Count, 2).End(3).Row Range("Ba7:Ba" & lr).SpecialCells(4).EntireRow.Delete On Error GoTo 0 End Sub الملف مرفق Najehoun.xlsm