يوسف عطا قام بنشر يوليو 9, 2018 قام بنشر يوليو 9, 2018 مرفق ملف للتوضيح لكل طالب صفين متتاليين بهما بعض الخلايا مدمجة فى الصفين مثل الإسم ورقم الجلوس و النتيجة و الرقم السرى و توجد بعض الخلايا غير مدمجة مثل درجة الدور الأول ودرجة الدور الثانى فى نفس المادة فى عدة مواد المطلوب عندما أختار التصفية التلقائية بناء على نتيجة الطالب فى الخلايا المدمجة رأسياً يظهر السطرين كاملين لكل طالب بدلا من أن يظهر سطر واحد و ربما المرفق يوضح الفكرة أفضل دور2.xls
سليم حاصبيا قام بنشر يوليو 9, 2018 قام بنشر يوليو 9, 2018 الفلتر لا يعمل كما يجب اذا كان هناك خلايا مدمجة بالجدول اذا كنت تريد يمكن استحراج النتائج بواسطة الماكرو او المعادلات
يوسف عطا قام بنشر يوليو 9, 2018 الكاتب قام بنشر يوليو 9, 2018 اشكرك جزيل الشكر أستاذ سليم على إهتمامك بالفعل تم إستخدام المعادلات لمعرفة نتيجة الطالب بعد وضع الدرجات فى الملف الأصلى وسوف أرفقه لمعاليكم غداً ولكن الهدف من إستخدام التصفية التلقائية أن تكون صفحة طبع النتيجة هى نفسها صفحة غستخراج النتيجة بدون إستخدام كود الترحيل ل 3 صفحات أخرى حيث النتائج ستكون ثلاثة 1. طالبات ناجحات ومنقولات 2. طالبات راسبات ولهن حق الإعادة بالمدرسة 3. طالبات راسبات وليس لهن حق الإعادة بالمدرسة على كل حال سيكون الأمر أكثر وضوحاً عندما أرسل لمعاليكم الملف تحياتى لمعاليكم سليم بك
سليم حاصبيا قام بنشر يوليو 9, 2018 قام بنشر يوليو 9, 2018 تم معالجة الأمر بالنسبة للملف القديم الذي رفعته الكود Option Explicit Sub filter_ME() If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1") Dim T_sh As Worksheet: Set T_sh = Sheets("Salim") Dim lr%, i%, new_lr%, k%, x Dim My_Table As Range: Set My_Table = _ S_sh.Range("A6").CurrentRegion ReDim arr(1 To 4) arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11 With T_sh .Range("A4").Resize(1000, 11).ClearContents .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)" My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _ .Range("A4"), 0 .Range("Q2").ClearContents End With '====================== lr = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row If lr < 5 Then lr = 5 For i = lr To 6 Step -1 Rows(i).Insert Next new_lr% = Sheets("Salim").Cells(Rows.Count, 1).End(3).Row If new_lr% < 6 Then new_lr% = 6 For i = 6 To new_lr% + 1 Step 2 x = Application.Match(T_sh.Cells(i - 1, 1), _ S_sh.Columns(1), 0) + 1 T_sh.Cells(i, 4).Resize(, 7).Value = _ S_sh.Cells(x, 4).Resize(, 7).Value Next For i = 5 To new_lr% Step 2 For k = 1 To 4 T_sh.Cells(i, arr(k)).Resize(2, 1).MergeCells = True Next Next '========================== Exit_Me: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق (انظر الى الصفحة salim ) دورsalim.xls
سليم حاصبيا قام بنشر يوليو 10, 2018 قام بنشر يوليو 10, 2018 تم معالجة الأمر بالنسبة للملف القديم الذي رفعته (نمو ذج اخر على 3 صفحات مستقلة مع تحديد نطاق الطباعة اللازم لكل صفحة) الكود Option Explicit Sub filter_ME3() If ActiveSheet.Name <> "ورقة1" Then GoTo Exit_Me With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim S_sh As Worksheet: Set S_sh = Sheets("ورقة1") Dim T_sh As Worksheet Dim lr%, i%, new_lr%, k%, x Dim My_Table As Range: Set My_Table = _ S_sh.Range("A6").CurrentRegion Select Case S_sh.Range("b1") Case "ناجح" Set T_sh = Sheets("Salim") Case "راسب وله حق الإعادة" Set T_sh = Sheets("Salim1") Case "راسب وليس له حق الإعادة" Set T_sh = Sheets("Salim2") Case Else GoTo Exit_Me End Select ReDim arr(1 To 4) arr(1) = 1: arr(2) = 2: arr(3) = 3: arr(4) = 11 With T_sh .Select .Cells(4, 1).Resize(1000, 11).ClearContents .Cells(1, 1) = S_sh.Range("b1") .Range("Q2").Formula = "=AND(ورقة1!$K7=$A$1,ورقة1!$K8=0)" My_Table.AdvancedFilter 2, .Range("Q1:Q2"), _ .Range("A4"), 0 .Range("Q2").ClearContents .Cells(1, 1) = vbNullString '====================== lr = .Cells(Rows.Count, 1).End(3).Row If lr < 5 Then lr = 5 For i = lr To 6 Step -1 Rows(i).Insert Next new_lr% = .Cells(Rows.Count, 1).End(3).Row If new_lr% < 6 Then new_lr% = 6 For i = 6 To new_lr% + 1 Step 2 x = Application.Match(.Cells(i - 1, 1), _ S_sh.Columns(1), 0) + 1 .Cells(i, 4).Resize(, 7).Value = _ S_sh.Cells(x, 4).Resize(, 7).Value Next For i = 5 To new_lr% Step 2 For k = 1 To 4 .Cells(i, arr(k)).Resize(2, 1).MergeCells = True Next Next End With '========================== Exit_Me: Erase arr With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق دورsalim 3 sheets.xlsFetching info... 1
يوسف عطا قام بنشر يوليو 10, 2018 الكاتب قام بنشر يوليو 10, 2018 تحياتى لمعاليكم سليم بك جارى نقل الكود للملف مع محاولة تطويعه للملف الأصلى حيث الملف المرسل سابقاً كالن مجرد لتوضيح الفكرة و هستأذن معاليكم لو لم استطع التعامل مع الكود أن تعمل على الملف الذى سأرسله لاحقاً دمت بود
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.