سليم حاصبيا

جرب هذا الكود في الملف المرفق Option Explicit Sub Colrorize() Dim i%, arr(1 To 10) Dim my_rg As Range Set my_rg = Range("a10").CurrentRegion For i = 1 To 10 arr(i) = Cells(10, i).Interior.ColorIndex Next For i = 1 To 10 my_rg.Columns(i).Interior.ColorIndex = arr(i) Next End Sub Rem]]]]]]]]]]]]]]]]]]]]]]]]]] Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Application .ScreenUpdating = False .EnableEvents = False End With Dim st: st = Target.Address Dim Change_range As Range Set Change_range = Range("a10").CurrentRegion If Not Intersect(Target, Change_range) Is Nothing Then Colrorize Cells(Target.Row, 1).Resize(, 10).Interior.ColorIndex = 6 End If With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Color_sa.xlsm

اريد اظهار بعض هذة البيانات فقط ؟؟؟؟ الاكسل لا يفهم كلمة بعض (حدد الكمية 5 / 10 / 15 / 30 % الخ.)

في الخلية E4 هذه المعادلة ثم اسحب نزولاً =IF(COUNTIF($A$4:A4,A4)=SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد")),"",COUNTIF($A$4:A4,A4)-SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"))) و اذا لم تعمل معك استبدل الفاصلة " , " بفاصلة منقوطة " ; " لتصبح هكذا =IF(COUNTIF($A$4:A4;A4)=SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"));"";COUNTIF($A$4:A4,A4)-SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد"))) الملف مرفق Tasalsul.xlsx

انا شخصياً لم افهم شيئاً رجاءً قم بوضع بعض البيانات (حوالي 5 صفوف) واكتب يدوياُ النتائج المتوقعة في الصفحتين

في الملف 3 اوراق عن اي ورقة تتحدث و هل يمكن ادراج بعض البيانات

تم معالجة الامر Option Explicit 'Created by Salim Hasbaya 2/5/2019 Sub New_tarhil() Application.ScreenUpdating = False Dim arr_s(1 To 11) Dim arr_t(1 To 11) Dim i%, RO_Num%, Final_Row% Dim RO_s% Dim RGS As Range Dim source_sh As Worksheet Set source_sh = Sheets("أدخال") 'from Dim target_sh As Worksheet Set target_sh = Sheets("اليومية") 'to '================================= RO_s = source_sh.Cells(Rows.Count, "A").End(3).Row + 1 If RO_s = 6 Then MsgBox "No Data To Transfer": GoTo LEAVE_ME_OUT RO_Num = source_sh.Range("a5"). _ CurrentRegion.Rows.Count Set RGS = source_sh.Range("a5"). _ CurrentRegion.Offset(1).Resize(RO_Num - 1) RO_Num = RGS.Rows.Count Final_Row = target_sh.Cells(Rows.Count, "D").End(3).Row + 1 '========================= For i = 1 To 11: arr_s(i) = i: Next For i = 1 To 3: arr_t(i) = i + 3: Next arr_t(4) = 9: arr_t(5) = 10 For i = 6 To 11: arr_t(i) = i + 8: Next For i = 1 To UBound(arr_s) target_sh.Rows(Final_Row). _ Cells(arr_t(i)).Resize(RO_Num).Value = _ RGS.Cells(1, arr_s(i)).Resize(RO_Num).Value Next Erase arr_t: Erase arr_s LEAVE_ME_OUT: Application.ScreenUpdating = True End Sub File Unclouded SAlim_ Prog_new1.xlsm

استبدل الى هذا الماكرو Sub tarhel() Dim source_sh As Worksheet: Set source_sh = Sheets("أدخال") 'from Dim target_sh As Worksheet: Set target_sh = Sheets("اليومية") 'to Dim larow% larow = target_sh.Cells(Rows.Count, "D").End(3).Row + 1 If larow < 4 Then larow = 4 Dim RO_Num% RO_Num = source_sh.Range("a5").CurrentRegion.Rows.Count target_sh.Cells(larow, 4).Resize(RO_Num - 1, 11).Value = _ source_sh.Range("a6").Resize(RO_Num - 1, 11).Value End Sub و اضافة هذه المعادلة الى الى الخلية C4 من الورقة اليومية والسحب نزولاً =IF(D4="","",MAX($C$3:C3)+1) الملف مرفق SAlim_ Prog.xlsm

الملف مضروب بفيروس و قد رفض الحهاز فتحه

يجب ان تقوم بتسمية الصفحات تماماً كما في الملف المرفوع من قبلي و تأكد ان كلمات الأول / الثاني / الثالث مكتوبة بالضبط كما في الصفحات دون زيادة مسافات او نقصانها

استاذ وجيه كود ممتاز ولكن ملاحظة بسيط تخفيفاً للكود ان بعض الورقات عير معنية بالكود مثل اخر ثلاث ورقات 1-لذلك لا لزوم لاجراء الحلقات التكرارية عليها (توفيراً للوقت وحجم الملف) 2- يمكن تلافي ذلك بادراج اسماء الصفحات المعنية ضمن Array والعمل على هذه الصفحات من خلال الـــ Array نفسه 3-بدل تكرار نفس السطر (مع تغيير العدد من 5 الى 12) في هذا الجزء من الكود '++++++++++++++++++++++++++++++++++++++++ Cells(k, 5) = Sheets(r).Cells(i, 5) Cells(k, 6) = Sheets(r).Cells(i, 6) Cells(k, 7) = Sheets(r).Cells(i, 7) Cells(k, 8) = Sheets(r).Cells(i, 8) Cells(k, 9) = Sheets(r).Cells(i, 9) Cells(k, 10) = Sheets(r).Cells(i, 10) Cells(k, 11) = Sheets(r).Cells(i, 11) Cells(k, 12) = Sheets(r).Cells(i, 12) '+++++++++++++++++++++++++++++++++++++++++++++ يمكن كتابة هذا القسم من الكود بهذا الشكل Dim x As Byte For x = 5 To 12 Cells(k, x) = Sheets(r).Cells(i, x) Next اما بالنسبة للسؤال الثاني يمكن عمل اوتو فلتر على الورقة فصول المدارس في عامود رقم اللجنة دون حلقات تكرارية (بعد اذنك طبعاً) ☺️

الملف عندك كبير جداً 5 صفحات في 1200 صف مما لا يسهل عملية متابعة الكود دائماً وابداً ارجو منك ومن جميع من له مشاركات او اسئلة ان يرفق مثال مبسط عما يريدونه ،وذلك لوضع الكود المناسب و من ثم تعميمه على الملف الأصلي تم اختصار الملف الى حوالي 20 اسم في كل صفحة وتغيير اسماء الصفحات لسهولة عمل الكود (في حال اضافة مدارس جديدة) الكود (في حدث الصفحة فقط اختر الصف الذي تريده ليقوم الكود بغمله) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$D$1" And Target.Count = 1 Then Copy_data End If Application.EnableEvents = True End Sub Rem======================== Rem======================== Rem======================== Sub Copy_data() Dim My_Sh As Worksheet Dim Arr(), i#, st Dim m#: m = 4 Dim x# Dim k As Byte: k = 1 Dim My_tabL As Range Set My_Sh = Sheets("FOUSUL") My_Sh.Range("a4:I" & Rows.Count).ClearContents st = My_Sh.[D1] For i = 1 To Sheets.Count If Mid(Sheets(i).Name, 1, 3) = "SHC" Then ReDim Preserve Arr(1 To k) Arr(k) = Sheets(i).Name k = k + 1 End If Next For k = LBound(Arr) To UBound(Arr) With Sheets(Arr(k)) If .FilterMode Then .ShowAllData .AutoFilterMode = False End If Set My_tabL = .Range("b3").CurrentRegion x = My_tabL.Rows.Count My_tabL.AutoFilter 5, st My_tabL.Offset(1).Resize(x - 1).SpecialCells(12).Copy _ My_Sh.Range("A" & m) m = My_Sh.Cells(Rows.Count, 2).End(3).Row + 1 If .FilterMode Then .ShowAllData .AutoFilterMode = False End If End With Next Erase Arr: Set My_tabL = Nothing End Sub الملف مرفق Mult_filtre _salim.xlsm

بالنسبة للسؤال في أول مشاركة جرب الملف المرفق اما بالنسبة للمشاركات الباقية استعمل المعادلات التي ادرجها لك الاستاذ بن علية الكود للملف Option Explicit Private Sub COMBO_MADDA_DropButtonClick() Application.ScreenUpdating = False Dim Srs As Worksheet Dim Sal As Worksheet Dim i%, Lr_Srs Dim comBo_dic As Object Set comBo_dic = CreateObject("scripting.dictionary") Set Srs = Sheets("source"): Set Sal = Sheets("salim") Lr_Srs = Srs.Cells(Rows.Count, 1).End(3).Row For i = 3 To Lr_Srs If Not comBo_dic.exists((Srs.Range("b" & i).Value)) Then comBo_dic.Add Srs.Range("b" & i).Value, "" End If Next COMBO_MADDA.List = Application.Transpose(comBo_dic.keys) fil_COMBO_PROF Application.ScreenUpdating = True End Sub Sub fil_COMBO_PROF() Dim k%: k = 3 Dim x%: x = 1 Range("M4:M100").ClearContents Dim Arr() If Sheets("salim").Cells(2, 3) = vbNullString Then Exit Sub Do Until Sheets("source").Cells(k, 2) = vbNullString If Sheets("source").Cells(k, 2) = Sheets("salim").Cells(2, 3) Then ReDim Preserve Arr(1 To x) Arr(x) = Sheets("source").Cells(k, 1) x = x + 1 End If k = k + 1 Loop COMBO_PROF.List = Application.Transpose(Arr) COMBO_PROF.Value = Arr(1) Range("M4").Resize(x - 1) = Application.Transpose(Arr) Erase Arr End Sub Nitakat.xlsm

جرب هذا الكود Option Explicit Sub Print_Areas() With Sheets("List") Dim lr%: lr = .Cells(Rows.Count, 1).End(3).Row With .PageSetup .PrintArea = Range("a1:I" & lr).Address .PrintTitleRows = "$1:$2" End With End With End Sub الملف مرفق ESSA_new.xls

حل بالمعادلات صفحة "By_Equation" HOW_MANY_new.xlsm

يمكن تعبئة الخلايا الفارغة بدون (Sort) ابجدياً بواسطة هذا الماكرو Option Explicit Sub give_Data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim last_ro# last_ro = Range("a1").CurrentRegion.Rows.Count Range("MM2").Resize(last_ro - 1).Formula = _ "=IF(AND(C2<>"""",D2<>""""),D2,INDEX($D$2:$D$" & last_ro & ",MATCH(C2,$C$2:$C$" & last_ro & ",0))" & ")" Range("D2").Resize(last_ro - 1).Value = _ Range("MM2").Resize(last_ro - 1).Value Range("MM2").Resize(last_ro - 1) = vbNullString With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق FiLL_Empty.xlsm

من أول نظرة الى الملف لاجظت ان تتابع الأسماء المكررة لذلك اقترحت هذا الماكرو اذا لم تكن الأسماء المكررة متتابعة بجب اولا ترتيبها (Sort) ابجدياً ثم ينفذ الماكرو

جرب هذا الماكرو Sub SALIM_MACRO() On Error Resume Next Columns("D:D").SpecialCells(4) _ .FormulaR1C1 = "=R[-1]C" '4 =====> xlCellTypeBlanks On Error GoTo 0 End Sub

بعد اذن اخي ابراهيم جرب هذا الملف (يمكن استخراج اي شيء) ليس فقط الارقام HOW_MANY.xlsm

الف مبروك ومن تقدم الى تقدم ترقية مستحقة ان شاء الله

الف مبروك اخي علي على هذه الترقية التي تستحقها بجدارة ان شاء الله سوياُ الى أبعد من الواجب

ورد خطأ بسيط في الكود (سطر زيادة ) الكود من جديد Option Explicit Sub transferData_New() Dim LR1 As Long Dim LR2 As Long Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1") Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2") Dim x% LR1 = sh1.Range("A" & Rows.Count).End(3).Row LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1 If LR2 = 2 Then LR2 = 1 x = sh1.Range("a1:D" & LR1). _ Find("", after:=sh1.Cells(13, 1)).Row - 1 sh1.Cells(1, 1).Resize(x, 4).Copy With sh2.Cells(LR2, 1) .PasteSpecial 12 .PasteSpecial -4122 End With sh1.Cells(LR1, 1).Resize(, 4).Copy With sh2.Cells(x + 1, 1) .PasteSpecial 12 .PasteSpecial -4122 Rem .Cells(x - 15, 4).Value = _ sh1.Cells(x + 1, 4).Value End With Application.CutCopyMode = False End Sub

تم معالجة الامر Option Explicit Sub transferData_New() Dim LR1 As Long Dim LR2 As Long Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1") Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2") Dim x% LR1 = sh1.Range("A" & Rows.Count).End(3).Row LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1 If LR2 = 2 Then LR2 = 1 x = sh1.Range("a1:D" & LR1). _ Find("", after:=sh1.Cells(13, 1)).Row - 1 sh1.Cells(1, 1).Resize(x, 4).Copy With sh2.Cells(LR2, 1) .PasteSpecial 12 .PasteSpecial -4122 End With sh1.Cells(LR1, 1).Resize(, 4).Copy With sh2.Cells(x + 1, 1) .PasteSpecial 12 .PasteSpecial -4122 .Cells(x - 15, 4).Value = _ sh1.Cells(x + 1, 4).Value End With Application.CutCopyMode = False End Sub

الشيت ثقيل لانك تجعل الكود ينتظر ثانية واحدة في كل خطوة من خلال الدالة Wait ما مجموعه (55 × 57 =4125 ثانية اي حوالي ساعة وربع) جرب هذا الماكرو Sub salama() Application.ScreenUpdating = False Dim My_num, i#, col# Dim color_index% color_index = 1 + 18 * Rnd() For i = 3 To 55 For col = 2 To 57 Select Case Cells(i, col) Case 1: My_num = 2 Case 2: My_num = 3 Case 3: My_num = 1 Case Else: My_num = "" End Select Cells(i, col) = My_num Cells(i, col).Interior.colorindex = color_index Next Next Application.ScreenUpdating = True End Sub '=================================== 'هذا الكود للتصحيح في حال ادخال رقم مختلف بالخطأ Sub reset() Application.ScreenUpdating = False Dim i#, col# For i = 3 To 55 For col = 2 To 57 If Cells(i, col) <> vbNullString Then _ Cells(i, col) = 1 Next Next Application.ScreenUpdating = True End Sub 2030.xlsm

لا جاجة للحاقات التكراراية استبدل الكود بهذا Option Explicit Sub transferData() Dim LR1 As Long Dim LR2 As Long Dim sh1 As Worksheet: Set sh1 = Sheets("ورقة1") Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2") LR1 = sh1.Range("A" & Rows.Count).End(3).Row LR2 = sh2.Range("A" & Rows.Count).End(3).Row + 1 If LR2 = 2 Then LR2 = 1 sh1.Cells(1, 1).Resize(LR1, 4).Copy With sh2.Cells(LR2, 1) .PasteSpecial 12 .PasteSpecial -4122 End With Application.CutCopyMode = False End Sub الملف مرفق TARHIL_SALIM.xlsm

بالنسبة لزيادة الصفوف بمكن ذلك لكن الملف يصبح ثقيل جداً ويأخذ وقتاً لنتفيذ كل المعادلات (10000 معادلة مع كل ضغطة على اي مفتاح من الكيبورد) لذلك اقترح هذا الماكرو Option Explicit Sub extract_data() If ActiveSheet.Name <> "salim_macro" Then GoTo Leave_Me_Olone Application.ScreenUpdating = False Dim Ro%, Col%, i%, k%, lrA%, LrC% Dim Arr Ro = 4: Col = 5 lrA = Cells(Rows.Count, 1).End(3).Row LrC = Cells(Rows.Count, 3).End(3).Row With Range("E4").Resize(lrA * LrC, 500) .ClearContents .Interior.ColorIndex = xlNone End With For i = 4 To lrA For k = 4 To LrC Arr = Trim(Split(Range("C" & k), "-")(0)) If Trim(Range("A" & i)) = Arr Then With Cells(Ro, Col) .Value = Range("C" & k) .Columns.AutoFit .Interior.ColorIndex = 4 End With Col = Col + 1 End If Next Ro = Ro + 1: Col = 5 Next Leave_Me_Olone: Application.ScreenUpdating = True End Sub الملف مرفق صفحة "salim_macro" File_Macro.xlsm