سليم حاصبيا

بعد اذن الاخ رضوان في J9 هذه المعادلة =CHOOSE(((E9<>"")+(F9<>"")+(G9<>"")+(H9<>"")+(I9<>"")=5)+1,"",SUM(E9:I9)) في K9 هذه المعادلة =IF(N(J9)=0,"",CEILING(J9/4,0.1)) في N9 هذه المعادلة =IF(N(K9)>=5,"ينتقل","يكرر") الملف مرفق hicham_1.xlsx

ربما كان المطلوب في هذا الملف Tab3i.xlsx

حيث انك لم ترفع ملف للمعاينة وانا اقدر ذلك (300 صفحة)لكن يمكن التجربة على عدد اقل يكثير(3 الى 10 صفحات) اليك هذا النموذج تكتب في الكود مكان Sheet1 اسم الشبت الرئيسي (حيث يجب الذهاب اليه) Option Explicit Sub select_Main() Sheets("Sheet1").Select ' Change the Name as you like End Sub '++++++++++++++++++++++++++++ Sub Insert_but() Dim wks As Worksheet For Each wks In ThisWorkbook.Worksheets If wks.Name <> "Sheet1" Then wks.Select ActiveSheet.Buttons.Delete wks.Buttons.Add(100, 50, 150, 25).Select Selection.Caption = "Goto Main Sheet" Selection.OnAction = "select_Main" End If Next wks Sheets("Sheet1").Select End Sub الملف مرفق للتجربة Insert_but_to every_sheet.xlsm

بعد اذن احي أحمد حرب هذا الكود Option Explicit Sub Order_by() Dim Mmax%, i%, y%, t%, NB Dim Dic As Object, S_lst As Object Dim ky, x, arr Dim Sh As Worksheet, Main As Worksheet Set Sh = Sheets("Salim") Set Main = Sheets("Sheet1") Set Dic = CreateObject("Scripting.Dictionary") Set S_lst = CreateObject("System.Collections.SortedList") With Sh.Cells(1, 1) .CurrentRegion.Clear .Offset(, 3) = "Itemno": .Offset(, 4) = "Pack Qty" .Resize(, 7).Interior.ColorIndex = 6 End With x = 2 With Main Mmax = .Cells(Rows.Count, 1).End(3).Row For i = 2 To Mmax + 1 If Main.Range("A" & i) = vbNullString Then GoTo Next_I Dic(Dic.Count) = .Range("A" & i) & "*" & .Range("B" & i) & "*" & _ .Range("C" & i) & "*" & .Range("D" & i) & "*" & _ .Range("E" & i) & "*" & .Range("F" & i) & "*" & _ .Range("G" & i) S_lst.Add (.Range("F" & i)) + (i - 2) / 100000, i - 2 Next_I: Next End With '+++++++++++++++++++++++++++ For i = 0 To S_lst.Count - 2 For y = 0 To 6 arr = Split(Dic.items()(i), "*") Sh.Cells(x, 1).Offset(, y) = arr(y) Next y Sh.Cells(x, 1).Offset(, 5) = Round(S_lst.GetKey(i), 2) If Int(S_lst.GetKey(i)) = Int(S_lst.GetKey(i + 1)) Then x = x + 1 Else Sh.Cells(x + 1, "D") = "Itemno" Sh.Cells(x + 1, "E") = "Pack Qty" Sh.Cells(x + 1, 1).Resize(, 7).Interior.ColorIndex = 6 x = x + 2 End If Next Sh.Cells(1, 1).Resize(x - 1, 7).Borders.LineStyle = 1 Set Dic = Nothing: Set S_lst = Nothing Set Sh = Nothing: Set Main = Nothing End Sub الملف مرفق صفحة Salim nany4mg_1.xlsm

ربما تريد هذا الشيء (أفضل من التكرار) wazkr.xlsx

جرب هذا الملف الصفحة ٍSheet1 تحتوي على قائمة منسدلة في الحلية A3 تتجدث اوتو ماتيكياً كلما أجريت اي تعديل على البيانات بهذا الشيء يمكنك اختيار الرقم القومي من هذه القائمة (دون عناء كنابته من حهة و تلافياً للأحطاء من جهه اخرى 14 حرف اكثر أو اقل) hanafymahmood.xlsm

حسناً فعلت لكن اريد ان استفسر بالنسبة لسرعة تنفيذ الكود(هل ما زال بطيئاً؟؟) لمعرفة الوقت الذي استغرقه الماكرو (اجزاء من 1000 من الثواني) اضف الى الكود حسب ما في هذه الصورة

اولاً يجب ان أعرف من اين اتيت بهذه الأرقام

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

لا افهم ما الحاجة الى الحلقات التكرارية في هذه الحالة يكفي هذا الكود بعد تنفيذ الكود يتم استبدال المعادلات بقيمها الحقيقية من خلال الأمر (value=.value.) للتقليل من حجم الملف لانه يحنوي على 10 أعمدة (حيث يوجد معادلات) في كل واحد حوالي 10000 معادلة ( و بذلك لا يتم ارهاق البرنامج بحساب أكثر من 100 الف معادلة مع كل ضربة على الكيبورد او نقرة من الماوس) Sub Get_by_formula() Dim Last_ro%, New_row With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Sheets("Sheet3") Last_ro = .Cells(Rows.Count, 1).End(3).Row .Range("O2").Resize(Last_ro - 1, 13).Clear .Range("P2").Resize(Last_ro - 1, 3).Value = _ .Range("A2").Resize(Last_ro - 1, 3).Value .Range("P2").Resize(Last_ro - 1, 3).RemoveDuplicates _ Columns:=Array(1, 2, 3) New_row = .Cells(Rows.Count, "P").End(3).Row With .Range("O2").Resize(New_row - 1, 13) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 12 .InsertIndent 1 .Cells(1, 5).Resize(New_row - 1, 8).Formula = _ "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000),D$2:D$10000)" .Cells(1, 1).Resize(New_row - 1).Formula = _ "=SUMPRODUCT(--($P2&$Q2&$R2=$A$2:$A$10000&$B$2:$B$10000&$C$2:$C$10000))" .Cells(1, 13).Resize(New_row - 1).Formula = _ "=ROUND(AVERAGE(S2:Z2),2)" .Value = .Value End With End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الصفحة Sheet3 من هذا الملف Ali_1xlsm.xlsm

هذه لم أفهمها ارجو تعديد الكود ليشمل فقط الاعمدة الثلاثة الاولى وهي الصف والمادة والمدرسة سواء بالجدول الاساسي

جرب هذا الماكرو Option Explicit Sub add_row() Dim My_sh As Worksheet Dim mot$, Ro1, Ro2 Dim All_rg As Range Dim rg As Range, Find_rg As Range Set My_sh = Sheets("Sheet1") mot = "Pack Qty" Set rg = My_sh.Range("G:G") Set Find_rg = rg.Find(mot, lookat:=1) If Not Find_rg Is Nothing Then Ro1 = Find_rg.Row: Ro2 = Ro1 Do If All_rg Is Nothing Then Set All_rg = Find_rg Else Set All_rg = Union(All_rg, Find_rg) End If Set Find_rg = rg.FindNext(Find_rg) Ro2 = Find_rg.Row If Ro2 = Ro1 Then Exit Do Loop If Not All_rg Is Nothing Then Set All_rg = All_rg.Offset(1) All_rg.EntireRow.Insert End If End If End Sub الملف مرفق nany4mg.xlsm

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

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

الملف من جديد Ali_Mas_Special.xlsm

جرب هذا الكود Option Explicit Sub All_in_One() Dim Ob As Object Dim Lr, i Dim Sd#, Se#, Sf#, Sg#, _ Sh#, Si#, Sj#, Sk# Dim kY Dim Sal As Worksheet Set Sal = Sheets("Salim") Lr = Sal.Cells(Rows.Count, 1).End(3).Row Sal.Range("P2").Resize(Lr, 12).ClearContents Set Ob = CreateObject("Scripting.Dictionary") With Sal For i = 2 To Lr Sd = Sd + Val(.Cells(i, "D")): Se = Se + Val(.Cells(i, "E")) Sf = Sf + Val(.Cells(i, "F")): Sg = Sg + Val(.Cells(i, "G")) Sh = Sh + Val(.Cells(i, "H")): Si = Si + Val(.Cells(i, "I")) Sj = Sj + Val(.Cells(i, "J")): Sk = Sk + Val(.Cells(i, "K")) Ob(.Cells(i, 1) & "*" & .Cells(i, 2) & "*" & .Cells(i, 3)) = _ Sd & "*" & Se & "*" & Sf & "*" & Sg & "*" _ & Sh & "*" & Si & "*" & Sj & "*" & Sk If .Cells(i, 1) <> .Cells(i + 1, 1) Then Sd = 0: Se = 0: Sf = 0: Sg = 0: _ Sh = 0: Si = 0: Sj = 0: Sk = 0 End If Next For i = 0 To Ob.Count - 1 .Cells(2, "p").Offset(i).Resize(, 3) = Split(Ob.KEYS()(i), "*") .Cells(2, "S").Offset(i).Resize(, 8) = Split(Ob.iTEMS()(i), "*") Next .Cells(1, "P").CurrentRegion.Value = _ .Cells(1, "P").CurrentRegion.Value End With End Sub الملف مرفق صفحة Salim Ali_Mas.xlsm

تم العمل كما تريد New_Ahmmed.xlsm

زيادة في الموضوع 1- عند الضغط على اي سطر في الليست بوكس (ما عدا سطر العنوان طبعاً) تظهر لك بيانات الاسم في التكست بوكسات Shibl_Extra.xlsm

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

تم التعديل كما تريد Option Explicit Dim cnt% Sub Salim_color(rg As Range, _ k As Byte, n As Byte, _ Optional m As Long) Dim i If IsMissing(m) Then m = xlNone If Val(k) <= 0 Or k > 12 Then k = 12 k = Abs(k) If IsDate(rg) Then i = IIf(Month(rg) = k, n, m) If i = n Then cnt = cnt + 1 rg.Interior.ColorIndex = i Else rg.Interior.ColorIndex = xlNone End If End Sub '+++++++++++++++++++++++++++++++++++ Sub CKect_Up() Dim x%, y% cnt = 0 With Sheets("Sheet1") x = .Cells(Rows.Count, "C").End(3).Row For y = 1 To x Call Salim_color(.Cells(y, "C") _ , .Range("H2"), .Range("G2") _ , .Range("F2")) Next .Range("B2") = IIf(cnt = 0, "", cnt) End With End Sub Ahmmed_1.xlsm

جرب هذا الملف Option Explicit Sub Salim_color(rg As Range, _ k As Byte, n As Byte, _ Optional m As Long) Dim i If IsMissing(m) Then m = xlNone If Val(k) <= 0 Or k > 12 Then k = 12 k = Abs(k) If IsDate(rg) Then i = IIf(Month(rg) = k, n, m) rg.Interior.ColorIndex = i Else rg.Interior.ColorIndex = xlNone End If End Sub '+++++++++++++++++++++++++++++++++++ Sub CKect_Up() Dim x%, y% With Sheets("Sheet1") x = .Cells(Rows.Count, "C").End(3).Row For y = 1 To x Call Salim_color(.Cells(y, "C") _ , .Range("H2"), .Range("G2") _ , .Range("F2")) Next End With End Sub Ahmmed.xlsm

في هذا السطر من الكود استبدل B:B بـــ C:C

علمتني التجارب بعدم العمل مع اي جدول يحتوي عل خلايا مدمجة

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

هذه المعادلة في C2 و اسحب نزولاً =IF($B2="","",COUNTIF(B$2:B2,B2)) النلف مرفق Wadi.xlsx