سليم حاصبيا

جرب هذا الملف (فقط معادلات) Monthly_calandar.xlsx

هذه المعادلة =IF(ISNUMBER(FIND("-",A2)),REPLACE(A2,1,FIND("-",A2),""),A2)

ربما كان المطلوب الكود Option Explicit Sub fil_data() Dim S_rg As Range Dim I%, m% Dim st1$, st2$ Range("g3", Range("g4").End(4)).Resize(, 4).ClearContents Set S_rg = Range("b3", Range("b4").End(4)).Resize(, 4) For I = 1 To S_rg.Rows.Count If S_rg.Cells(I, 4) <> "مشطب" Then If S_rg.Cells(I, 3) & S_rg.Cells(I, 4) <> "3 جامعي" & "ناجح" Then Cells(m + 3, "G") = S_rg.Cells(I, 1) Cells(m + 3, "H") = S_rg.Cells(I, 2) Select Case S_rg.Cells(I, 3) & S_rg.Cells(I, 4) Case "1 جامعي" & "معيد": st1 = "1 جامعي": st2 = "نعم" Case "1 جامعي" & "ناجح": st1 = "2 جامعي": st2 = "لا" Case "2 جامعي" & "معيد": st1 = "2 جامعي": st2 = "نعم" Case "2 جامعي" & "ناجح": st1 = "3 جامعي": st2 = "لا" End Select Cells(m + 3, "I") = st1: Cells(m + 3, "j") = st2 m = m + 1 End If End If Next End Sub الملف مرفق jama3i.xlsm

قم بانشاء ملف نموذج عنه 20 الى 25 صف

الصورة لا تحل المشكلة يجب تحميل الملف نفسه

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

المشكلة عندك ان الصور كبيرة الحجم وتغطي قسم من البيانات بين الصفحة والتي تليها لا أعرف لماذا تم ادراج اكثر من 8 صفوف فارغة (يجب ازالتها لانها تظهر في الطباعة) قم بتنسبق كل الصفحات كما الصفحة 1 work_end.xlsx

هناك موضوع أكثر أهمية في هذا الملف حيث تستطيع اختيار المرتبة التي تشاء (ليس الخامسة فقط بل الرابعة مثلا أو السابعة) تضع المرتبة التي تريد في الخلية E2 المعادلات في الملف محمية لعدم العبث بها عن طريق الخطأ Choose_grade.xlsm

جرب هذا الملف Grade By_Item.xlsm

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

جرب هذا الملف Hidden_sheet.xlsm

افترض أن كل العلامات 25 يذلك المجموع لا يصل الى 90

20 في العمود الأول و 23 في العمود الثاني و 25 في العمود الثالث و 22 و كبف تريد الحد الادنى 25

لم افهم الفكرة لكن هذا احد المحاولات (ربما يكون احدها المطلوب) compaire_tables.xlsx

اخي بن علية لك كل الاحترام والتقدير و أحب أن اذّكر ان الأكواد التي أضعها(بكل تواضع) هي بتصرف كل شخص طالب للعلم وأحيّ فيك روح احترام حقوق النشر و المكليّة (بذكر اسم واضعي الاكواد) واخيراً بالاذن منك اخي بن علية أقدّم هذا الحل مع تحياتي أخوكم سليم Important.xlsm

تم عمل المطلوب الكود Option Explicit Sub filter_for_ME() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim t_sh As Worksheet: Set t_sh = Sheets("حساب الجمعية4") Dim s_sh As Worksheet: Set s_sh = Sheets("معلومات أولية") Dim My_Table As Range: Set My_Table = t_sh.Range("A10").CurrentRegion t_sh.Range("Bn2").Formula = "=B11>='معلومات أولية'!$C$2" My_Table.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=t_sh.Range("BN1:BN2") t_sh.Range("BN2").ClearContents With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub '====================================== Sub show_All() On Error Resume Next Sheets("حساب الجمعية4").ShowAllData On Error GoTo 0 End Sub الملف مرفق Ta3dil.xlsm

ممكن تجرب هذا الملف الكود Option Explicit Sub Give_Uniques() With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With With salim Dim m%: m = 3: Dim Col%: Col = 5 Dim R%, T% Dim Cel As Range, S_RG As Range Dim Find_RG As Range, A_RG As Range .Range("D3").CurrentRegion.ClearContents Set A_RG = .Range("A3").CurrentRegion.Columns(1) .Range("D3").Resize(A_RG.Rows.Count).Value = _ A_RG.Value .Range("D3").CurrentRegion.RemoveDuplicates 1, 0 Set S_RG = .Range("D3").CurrentRegion.Columns(1) For Each Cel In S_RG.Cells Set Find_RG = A_RG.Find(Cel, after:=A_RG.Cells(A_RG.Rows.Count)) R = Find_RG.Row: T = R Do .Cells(m, Col) = .Cells(R, 2): Col = Col + 1 Set Find_RG = A_RG.FindNext(Find_RG) R = Find_RG.Row If R = T Then Exit Do Loop m = m + 1: Col = 5 Next End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With End Sub الملف مرفق (فقط 90 كيلوبايت) check_salim.xlsm

سأعمل على هذا ان شاء الله بعد الانتهاء من العمل من فضلك أرفع الملف ثانية لاني قد مسحته من جهازي

جرب هذا الملف كنموذج Super Adv_Filter.xlsm

بعد اذن الأخ أبي الِشهيد بإذن الله جمعة الحلقات التكرارية كما هو معروف ترهق الاكسل(اذا كان هناك الوف الصفوف) لذلك يجب قدر الامكان الابتعاد عنها كود بديل ربما يكون اسرع لأنه كما يقولون يضع يده على الجرح مباشرة (أي انه يقوم بإيجاد الصف المطلوب و يخغيه بدون الحلقات التكرارية ) Private Sub CommandButton1_Click() Dim ws As Worksheet, wss As Worksheet Dim lrr%, i% Dim My_row% Dim row_n% Set ws = Sheets("معلومات أولية") Set wss = Sheets("حساب الجمعية2") Dim s_range As Range no1 = ws.Range("c2") wss.Rows.Hidden = False On Error Resume Next Set s_range = wss.Range("B:B").Find(no1, lookat:=xlWhole) My_row = s_range.Row On Error GoTo 0 If My_row = 0 Then Exit Sub row_n = My_row: Rows(row_n).Hidden = True Do Set s_range = wss.Range("B:B").FindNext(s_range) My_row = s_range.Row If My_row = row_n Then Exit Do Rows(My_row).Hidden = True Loop End Sub

ممكن أن يكون المطلوب RESULT.xlsx

السبب في ذلك ان الارقام في العامود F غير مرتبة تتازلياً

لاجظ كا يلي 1-الخلايا F13 و F14 غير متساووين (نرى ذلك بعد أصافة كل الاعداد بعد الفاصلة) 2-لماذا لا تستعمل الدالة المذكورة في العامود الاخضر طالما انها موجودة في الملف (Order_Salim(RANK(F8,$F$8:$F$17 3- الملف كبير جداً (أكثر من 3 ميغا ) و لا أعلم السبب مع أن البيانات قليلة الملف مرفق Three_s.xls

ممكن عمل هذا لكن المشكلة أن البيانات كبيرة جداً (حواليي 5000 صف)مما يستغرق وقتاً كبيراً (حوالي 20 ثانية لتنفيد هذه المعادلات مع أي تغيير يطرأ في اي خلية من الصغحة) ( 5000 × 5 أعمدة =25000 معادلة) بالاضافة إلى تكبير حجم الملف إلى حوالي 1 Mega لذلك طريقة العمل باستخدام كود برمجي يكون أفضل انا قمت بالحل عن طريق النعادلات وهذه النتيجة check_Salim1.xlsx

ربما كان المطلوب check_Salim.xlsx