سليم حاصبيا

تم معالجة الأمر اود ان يكون الكود لجلب أسماء المدارس فقط دون اي بيانات اخرى (يمكن التعديل كما تريد) من خلال الــ Loop Sub First_Third_New() Dim sh As Worksheet Dim sh1 As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object, Dic As Object Dim Lt, t% Dim Mn Application.ScreenUpdating = False Set sh = Sheets("Salim") Set sh1 = Sheets("Sheet1") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh1.Range("C8:M13").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh1.Range("V8") = "" Then sh1.Range("V8") = "Grade 1" If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language" Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) If My_rg.Areas.Count = 1 Then arr = Application.Transpose(My_rg) Else arr = Application.Transpose(My_rg.Areas(2)) End If For i = 1 To UBound(arr) If IsNumeric(arr(i)) Then Col.Add Val(arr(i)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next If sh.FilterMode Then My_rg.AutoFilter End If m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh1.Cells(m, "C") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop t = t + 1 If t = Dic.Count Then Exit Do Loop Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase arr End Sub Masry_Extra.xlsm

قم بتغيير اسم الملف بحيث يحتوي على xls. واحدة لا اثنتين

هذا الكود يدرج التكرار (صفحة Salim من هذا الملف) وضعته في صفحة مستقلة كي لا تتأثر الييانات في الصفحة الاساسية فقط عليك تعديلة كما تريد Sub First_Until_Third() Dim sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object, Dic As Object Dim Lt, t% Dim Mn Application.ScreenUpdating = False Set sh = Sheets("Salim") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh.Range("P9:Z20").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) arr = My_rg For i = 1 To UBound(arr) If IsNumeric(arr(i, 1)) Then Col.Add Val(arr(i, 1)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next If sh.FilterMode Then My_rg.AutoFilter End If m = 9: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh.Cells(m, "P") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop t = t + 1 If t = Dic.Count Then Exit Do Loop Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase arr End Sub Masry_NEW.xlsm

Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing Set F_rg = Nothing Set Col = Nothing ُErase arr End Sub

امسح هذه العبارة بالكامل حيث لا وجود للشيت Sheet1 و يالتالي Aux_sh Set Aux_sh = Nothing Aux_sh هذه العبارة موجودة Set Col = Nothing ولا لزوم لنكرارها

يمكن ذلك بواسطة هذا الكود Option Explicit Sub First_Sec_Third() Dim sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim arr, Col As Object Application.ScreenUpdating = False Set sh = Sheets("Data") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") sh.Range("P9:Z11").ClearContents ro = My_rg.Rows.Count If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 arr = My_rg.Columns(13).Offset(1) _ .Resize(ro - 1).SpecialCells(12) For i = 1 To UBound(arr) If IsNumeric(arr(i, 1)) Then Col.Add arr(i, 1) Next i Col.Sort Col.Reverse If sh.FilterMode Then My_rg.AutoFilter End If m = 9 Do Until m = 12 Set F_rg = My_rg.Find(Col(m - 9), lookat:=1) xx = F_rg.Row With sh.Cells(m, "P") .Value = sh.Cells(xx, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(xx, "D").Resize(, 9).Value .Offset(, 10) = F_rg End With m = m + 1 Loop Application.ScreenUpdating = True Set sh = Nothing: Set Aux_sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing End Sub Masry_collcetion.xlsm

جرب هذا الماكرو (هناك ورقة مخفية مساعدة Sheet1 ) الرجاء عدم مسحها Option Explicit Sub First_Sec_Third() Dim sh As Worksheet Dim Aux_sh As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim Cret1, Cret2 Dim ro As Long Dim k As Byte, m As Byte Application.ScreenUpdating = False Set Aux_sh = Sheets("Sheet1") Set sh = Sheets("Data") sh.Range("P9:Z11").ClearContents Set My_rg = sh.Range("A1").CurrentRegion ro = My_rg.Rows.Count If sh.Range("P4") = "" Then sh.Range("P4") = "Grade 1" If sh.Range("P3") = "" Then sh.Range("P3") = "Arabic Language" Cret1 = sh.Range("P4"): Cret2 = sh.Range("P3") Aux_sh.Range("A1").CurrentRegion.Clear If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, Criteria1:=Cret1 My_rg.AutoFilter Field:=3, Criteria1:=Cret2 My_rg.Columns(13).Offset(1).Resize(ro - 1).Copy Aux_sh.Range("A1").PasteSpecial (12) Aux_sh.Range("A1").CurrentRegion.SortSpecial , Order1:=2 If sh.FilterMode Then My_rg.AutoFilter End If k = 1: m = 9 Do Until k = 4 Set F_rg = My_rg.Find(Aux_sh.Range("A" & k), lookat:=1) xx = F_rg.Row With sh.Cells(m, "P") .Value = sh.Cells(xx, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(xx, "D").Resize(, 9).Value .Offset(, 10) = F_rg End With k = k + 1: m = m + 1 Loop Application.ScreenUpdating = True Set sh = Nothing: Set Aux_sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing End Sub Masry.xlsm

See This Video https://www.youtube.com/watch?v=WlTFQXEAFik&ab_channel=Mycomputer

ضع نفس الماكرو في حدث الصفحة الثانية مع تعديل في اسماء الصفحات

كود للصفحة الثانية يمكنك وضع كود مماثل للثالثة Private Sub CommandButton1_Click() Feuil2.Visible = 2 Dim My_pass, Inp_box My_pass = "ABC" Inp_box = InputBox("Please Type your Password", _ "Password") If UCase(Inp_box) <> My_pass Then Exit Sub Feuil2.Visible = -1 Feuil2.Select End Sub الملف مرفق Halim.xlsm

جرب هذا الملف (كبداية) العمل حسب الصورة البحث حسب هذه الصورة 1-تضع ما تريد البحث عته في TextBox 2- تضغط على الــــ Option But المناسب mohamedelfoly_Form.xlsm

try This macro Option Explicit Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False Dim My_Address$ My_Address = Target.Offset(8, 2).Address If Not Intersect(Target, Me.Range("B2:B5")) Is Nothing _ And Target.Cells.Count = 1 Then Me.Range(My_Address) = Target.Value Sheets("close").Range(My_Address) = Target End If Application.EnableEvents = True End Sub File Inclided Walid.xlsm

ما العمل وانت تقومين بتشكيل ملف مع صفحات غير منتظمة من حيث النتسيق في الصورة الرقم المستندى في عامود (C) في صفجة وفي عامود اخر D في صفحة اخرى لاخر مرة أقوم بالتصحيح فلا وقت للعمل يهذه الأمور (لان الكود يجب ان يبحث عن الرقم المستندى في عامود مجدد) الكود الجديد Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n%, K% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False K = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To K) ReDim Preserve Arr_Number(1 To K) Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K K = K + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 5 To ro If sh.Cells(i, 1) = vbNullString Then GoTo next_I If Application.CountA(sh.Cells(i, 4).Resize(, Col - 4)) = 0 Then GoTo next_I Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 3).Resize(, Col - 3). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ ' .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, 3) = sh.Cells(i, 3) .Offset(, -3).Resize(, 7).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If next_I: Next i Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents n = n + 1 Next t If m > 2 Then With Special_SH.Range("A2:G" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub Yara_New_.xlsm

تفضل بالمعادلات Maliki_FORMULA.xlsm

جرب هذا الكود Option Explicit Sub Hide_unhide() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Ar_cel, Ar_n, i% Set Sh1 = Sheets("Sheet1"): Set Sh2 = Sheets("Sheet2") Sh1.Range("d1:q1").EntireColumn.Hidden = False Ar_cel = Array("B", "E", "H", "J", "N") Ar_n = Array("E", "H", "k", "N", "Q") For i = LBound(Ar_cel) To UBound(Ar_cel) Sh1.Range(Ar_n(i) & 1).EntireColumn.Hidden = _ IIf(Sh2.Cells(7, Ar_cel(i)) = 0, -1, 0) Next i End Sub Jack.xlsm

اخر ما بمكنني عمله Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n%, K% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False K = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To K) ReDim Preserve Arr_Number(1 To K) Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K K = K + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 5 To ro If sh.Cells(i, 1) = vbNullString Then GoTo next_I If Application.CountA(sh.Cells(i, 3).Resize(, Col - 2)) = 0 Then GoTo next_I Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, -3).Resize(, 6).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If next_I: Next i Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents n = n + 1 Next t If m > 2 Then With Special_SH.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub الملف مرفق لمسح محتويات الشيتات بعد الترحيل ازالة كلمة Rem من هذا السطر من الكود (الصورة) Yara_WITH DEL_file.xlsm

جرب هذا الملف Option Explicit Sub One_by_one() Dim S As Worksheet Dim F_rg As Range Set S = Sheets("Salim") If S.Range("C2") = "" Then S.Range("C2") = 1 If S.Range("D2") = "" Then S.Range("D2") = "السبت" S.Range("B7").Resize(10, 2).ClearContents Select Case S.Range("C2") Case 1 Set F_rg = S.Range("B20:N20").Find(S.Range("D2"), lookat:=1) Case 2 Set F_rg = S.Range("B34:N34").Find(S.Range("D2"), lookat:=1) Case 3 Set F_rg = S.Range("B48:N48").Find(S.Range("D2"), lookat:=1) Case 4 Set F_rg = S.Range("B62:N62").Find(S.Range("D2"), lookat:=1) Case Else Exit Sub End Select If Not F_rg Is Nothing Then Range("B7").Resize(10, 2).Value = _ F_rg.Resize(10, 2).Value End If End Sub الملف مرفق Maliki.xlsm

المشكلة انه في الصفحة ميرنا 3 الصف الأول فارع (تم تعبئته والكود يعمل) الملف مرفق و لن أرد على اي سؤال يتعلق بنصميم الملف من جهة الصفوف الفارغة او التنسيق الذي لا يتناسب مع الكود الذي تم وضعه Yara_Last_file.xlsm

من قال لك ان تضعي صفين فارغين (الصف الاول والثاني) في كل صفحة

اضافة الى الكود كما في الصورة (في المكان المناسب)

استبدلي الرقم 2 بالرقم 5 في هذا السطر For i = 2 To ro

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

تعديل على الكود في الــ NO_arr ادخلت اسماء الشيتات التي لا أريدها لأن عدد الشيتات كبير (100) و بالتالي الأفضل ادخال الشيتات التي نريد استثناؤها Option Explicit Sub Get_Data() Dim Arr_SH(), t% Dim Arr_Number() Dim NO_arr, n% Dim x As Boolean Dim Special_SH As Worksheet Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, k%, i% Dim F_rg As Range NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _ "تقرير5", "تقرير6", "تقرير7") Set Special_SH = Sheets("تقرير تجميعى") Application.ScreenUpdating = False k = 1 For i = 1 To Sheets.Count x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0)) If x Then ReDim Preserve Arr_SH(1 To k) ReDim Preserve Arr_Number(1 To k) Arr_SH(k) = Sheets(i).Name: Arr_Number(k) = k k = k + 1 End If Next i m = 2 Special_SH.Range("A1").CurrentRegion.Offset(1).Clear For t = LBound(Arr_SH) To UBound(Arr_SH) Set sh = Sheets(Arr_SH(t)) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 2 To ro Special_SH.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Special_SH.Cells(m, 4) .Value = F_rg '+++++++++ By choise You can insert _ ' Sheets name or Sheet Number++++++++++++ ' .Offset(, 1) = Arr_Number(t) .Offset(, 1) = sh.Name '++++++++++++++++++++++++++++++++++ .Offset(, 2) = sh.Cells(1, F_rg.Column) .Offset(, -3).Resize(, 6).Interior.ColorIndex = _ IIf(n Mod 2 = 0, 24, 36) End With m = m + 1 End If Next i n = n + 1 Next t If m > 2 Then With Special_SH.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 ' .Interior.ColorIndex = 35 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" .Interior.ColorIndex = 40 .Value = .Value End With End With End If Application.ScreenUpdating = True End Sub الملف مرفق Yara_2.xlsm

ادراج اسماء الصفجات في Array يجب ان يكون بالضيط كتا هو اسم البشيت (دون مسافة زائدة او ناقصة) مثلاً اذا كان اسم الشيت اوفيسنا لا يجوز في الـــ كتابة اوفـــيسنا اذا كان اسم الشيت ِABC لا يجوز في الـــ كتابة A BC الأفضل نسخ اسم الشيت ولصقه في Array

افعلي ما تريدن شرط ان يتضمن الــ Array اسماء الشيتات ان كان باللفة الغربية او الأجنبية مثلاً ("Sheet1","الرقم 1", "سليم", "الرقم 3")=Array