ترحيل الطلبة الراسبة بناء علي مادة الرسوب باستخدام list

[ابو بهاء المصري]

السلام عليكم منتدي اوفيسنا الكبير والعظيم

والتحية لكل اعضائه الكرام

اجتهدت وحاولت وفشلت وفي النهاية وكالعادة لجئت اليكم

فانا ارغب في ترحيل البيانات من ورقة ola الي ورقة lagna بس فقط الطلبة الراسبة في المادة التي اقوم باختيارها من قائمة باسماء المواد وكما هو موضح في الملف والصور المرفقة  

جزاكم الله عنا خيرا

والي الامام دائما

قوائم لجان الدور الثاني - Copy.xlsx

[lionheart]

The file is not perfect. Generally try the following code

In standard module paste the following code

Option Explicit

Sub Get_Data_By_Subject()
    Const FIXEDROWS As Long = 20, FIXEDCOLS As Long = 5
    Dim a, v, xCol, ws As Worksheet, sh As Worksheet, rng As Range, i As Long, ii As Long, k As Long, iStart As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        With ThisWorkbook
            Set ws = .Worksheets("ola"): Set sh = .Worksheets("lagna")
        End With
        a = ws.Range("B6:T102").Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        xCol = Application.Match(sh.Range("L3").Value, ws.Rows(5), 0)
        If Not IsError(xCol) Then
            For i = LBound(a) To UBound(a)
                If a(i, xCol - 1) <> Empty Then
                    k = k + 1
                    For ii = LBound(a, 2) To UBound(a, 2)
                        b(k, ii) = a(i, ii)
                    Next ii
                End If
            Next i
            If k > 0 Then
                iStart = IIf(sh.Range("B9").Value = Empty, 1, sh.Range("B9").Value)
                Set rng = sh.Range("C9").Resize(FIXEDROWS, FIXEDCOLS)
                If iStart > k Then rng.ClearContents: GoTo Skipper
                v = ExtractArray(b, iStart, FIXEDROWS, FIXEDCOLS)
                sh.Range("B9").Resize(FIXEDROWS).Value = Evaluate("ROW(" & iStart & ":" & iStart + FIXEDROWS - 1 & ")")
                With rng
                    .ClearContents
                    .Value = v
                End With
            End If
        End If
Skipper:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function ExtractArray(ByVal arr, ByVal iStart As Long, ByVal iRows As Long, ByVal iCols As Long)
    Dim i As Long, ii As Long
    ReDim outputArr(1 To iRows, 1 To iCols)
    For i = iStart To iStart + iRows - 1
        For ii = 1 To iCols
            outputArr(i - iStart + 1, ii) = arr(i, ii)
        Next ii
    Next i
    ExtractArray = outputArr
End Function

 

In worksheet named Lagna paste the following module

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$L$3" Then
        Application.ScreenUpdating = False
            Range("B9:I28").ClearContents
        Application.ScreenUpdating = True
    End If
End Sub

 

By the way 

after selecting the subject click the down arrow of the spinner not the up arrow

[ابوحبيبه]

الحمد لله ... انك وجدت من يساعدك

لاني اهتميت بالموضوع  كثيرا

وكل الشكر للاخ  lionheart   

الذي نستفيد منه كثيرا . ومن جميع الخبراء بالمندى

تم تعديل يونيو 12, 2023 بواسطه ابوحبيبه

[ابو بهاء المصري]

شكرا للمساعدة يا lionheart 

لاكنه لم يعمل في املف ولم يعطي نتائج
اتمني حل باللغة العربية حتي استوعب الكود وافهمه

في الانتظار 

بارك الله فيكم

[lionheart]

I don't attach files

Wait someone to attach the file for you

Just follow the steps and you will be able to make it run properly

[عبدالله بشير عبدالله]

السلام عليكم 

lionheart

اعتقد ان صاحب الملف كما قال انه لم يعطى له نتائج بسبب عدم اضافة الكود Get_Data_By_Subject الى زر او الى صفحةLagna  فيكون كالاتي 

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$L$3" Then
        Application.ScreenUpdating = False
            Range("B9:I28").ClearContents
        Application.ScreenUpdating = True
    End If
Get_Data_By_Subject
End Sub

وهذا ملف كامل به كود استاذنا lionheart وقمت بالتجربة   فتم استدعاء الطلبة حسب المادة حقيقة سرعة ابداع اتقان زادك الله رفعة وعلما استاذنا الفاضل

الملف

قوائم لجان الدور الثاني - Copy.xlsb

[ابوحبيبه]

جزاء الله خيرا اخي ... lionheart 

جزاء الله خيرا اخي ...عبدالله بشير عبدالله

ما شاء الله ... الملف فعلا شغال ويستدعي البيانات المطلوبة .

لكن هناك ملحوظة 

لو ان الاسماء اكثر من 20 . عند الضغط على السهم لأعلى _ بجوار خانة المواد _ لا يعطيني الاسماء الباقية 

هل من طريقة للحصول على باقي الاسماء عند الضغط على السهم لأعلى

 

 

[عبدالله بشير عبدالله]

تم  ربط  زر التبديل ب 

Get_Data_By_Subject

قوائم لجان الدور الثاني - Copy.xlsb

[ابوحبيبه]

بارك الله فيك اخي الكريم

ودمتم بصحة وخير ... 

 

[lionheart]

No need to add this line to worksheet module

Get_Data_By_Subject

The code should be assigned to the spinner. After selecting the subject directly, click on the down arrow then use up arrow

[ابوحبيبه]

طلب اخير انا نسيته في المشاركة السابقة

عند الطباعة من الزر طباعة يطبع صفحة واحدة ... ولا يطبع باقي الصفحات اذا كان هناك صفحات كثيرة 

اريد ان اطبع باقي الصفحات ... هل يمكن ذلك 

وشكرا

[lionheart]

When executing the code the data will be changed with the next 20 names

You can add ActiveSheet.PrintOut line to print the worksheet

[ابوحبيبه]

شكرا اخي الفاضل على اهتمامك

     ... جزاك الله خيرا 

[ابو بهاء المصري]

بارك الله لكم جميعا اعضاء ومشرفي هذا المنتدي الكبير

ما اعظم عقولكم

وما ارقي مساعدتكم

ابوحبيبه

عبدالله بشير عبدالله

lionheart

لكم كل تقدير واحترام

[ابوحبيبه]

 

 

[عبدالله بشير عبدالله]

السلام عليكم 

السيد الفاضل ابو بهاء المصري نأمل منكم تعديل اختياركم افضل اجابة للسيد lionheart فهو من يستحقها وهو صاجب الكود . وعندما كان ردكم على اجابته

في 12‏/6‏/2023 at 21:18, ابو بهاء المصري said:

لاكنه لم يعمل في املف ولم يعطي نتائج
اتمني حل باللغة العربية حتي استوعب الكود وافهمه

فاجابكم استاذنا الفاضل 

انتظر شخص ما لإرفاق الملف من أجلك ما عليك سوى اتباع الخطوات وستتمكن من تشغيلها بشكل صحيح

 

في 12‏/6‏/2023 at 21:20, lionheart said:

 

Wait someone to attach the file for you

Just follow the steps and you will be able to make it run properly

وما قمت به انا وضع الكود بالملف واتباع الحطوات  ولم اغير في الكود نقطة واحدة 

فالحل قام به استاذنا lionheart  وهو صاحب الفضل

ففضلا لا امر تغيير اختياركم لافضل اجابة الى صاحب الفضل . 

تحياتي

[lionheart]

Never mind my bro Abdullah

Out target is not to get the best solution but to help others as possible as we can

May Allah bless you

[ابوحبيبه]

السلام عليكم

اللهم اجعل كل ما قدمتموه في ميزان حسناتكم

لكن عند ملحوظة :

انا جربت الكود في حالة كلمة ناجح _ راسب 

وكذلك بدلت ناجح _ راسب  بارقام عظمى ( 50 ) وصغرى ( 10)

الكود للاسف لم يعمل 

هل الكود يختص فقد بالخلية ان كانت فارغة ام لا . كما في النطاق الموجود

وهل يمكن تطويع الكود لتنفيذ ذلك . وكيف

وشكرا

 

 

[lionheart]

The code is working on all the data regardless the student status

[ابوحبيبه]

اخي الفاضل lionheart

عند التنفيذ ظهر ذلك ... الصورة الاولى الاسماء والمواد _ اللغة العربية

 

الصورة الثانية بعد اختيار اللغة

 

هذا ما اردت التنبيه له ... وشكرا لك سعة صدرك ... 

قوائم لجان الدور الثاني.xlsb

 

[lionheart]

I have no idea about what you are talking about. Sorry

[ابوحبيبه]

12 ساعات مضت, lionheart said:

The code is working on all the data regardless the student status

اخي الفاضل هذا ردك على مشاركتي

13 ساعات مضت, ابوحبيبه said:

السلام عليكم

اللهم اجعل كل ما قدمتموه في ميزان حسناتكم

لكن عند ملحوظة :

انا جربت الكود في حالة كلمة ناجح _ راسب 

وكذلك بدلت ناجح _ راسب  بارقام عظمى ( 50 ) وصغرى ( 10)

الكود للاسف لم يعمل 

هل الكود يختص فقد بالخلية ان كانت فارغة ام لا . كما في النطاق الموجود

وهل يمكن تطويع الكود لتنفيذ ذلك . وكيف

وشكرا

 

وهذا ردك الاخير

3 ساعات مضت, lionheart said:

I have no idea about what you are talking about. Sorry

اخي الفاضل ... لك مني كل الاحترام والتقدير

وشكرا علي ما قدمت 

[ابو بهاء المصري]

اخي الكبير / عبدالله بشير عبدالله

 

اقتباس

في 17‏/6‏/2023 at 16:18, عبدالله بشير عبدالله said:

السيد الفاضل ابو بهاء المصري نأمل منكم تعديل اختياركم افضل اجابة للسيد lionheart فهو من يستحقها وهو صاجب الكود . وعندما كان ردكم على اجابته

 

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

وطلبك هذا يا اخي علي العين والراس وهذا لا ينكر فضل مستر lionheart 

فله كل الفضل طبعا دون انكار من احد دخل هذا الموضوع

وايضا لا يسعني سوي شكركم جميعا
ولكم كل تقدير واحترام

[ابو بهاء المصري]

الاستاذ الفاضل/ ابوحبيبه

هذا ملف تعقيبا علي مشاركتك 

في 17‏/6‏/2023 at 23:15, ابوحبيبه said:

اخي الفاضل lionheart

عند التنفيذ ظهر ذلك ... الصورة الاولى الاسماء والمواد _ اللغة العربية

 

الصورة الثانية بعد اختيار اللغة

 

ولاكن احب ان اضيف ان الكود ليس سهلا ويجب تتبع كل خطوة وخرجاتها حتي تعلم اين موضع التغير في الكود حتي يناسب تعديلك 
وكنت اتمني معاددلات داخل الخلايا وليس كود VBA 

ومازالت هناك مشكلة في احضار باقي الاسماء بعد الـ 20 اسم الاولي وواجهتني تلك المشكلة حينما طوعت الكود ليتناسب مع الورقة المسماه thania 

فضلا عن هذه الرسالة الت تاتيني عند الحفظ

 

وارجو من الاستاذ lionheart ان يتقبل تعليقاتنا بكل صدر رحب

 

 

قوائم لجان الدور الثاني اولي.xlsb

تم تعديل يونيو 19, 2023 بواسطه ابو بهاء المصري
اضافة ملف

[عبدالله بشير عبدالله]

1 ساعه مضت, ابو بهاء المصري said:

وطلبك هذا يا اخي علي العين والراس وهذا لا ينكر فضل مستر lionheart

اخي ابو بهاء المصري / شكرا لخلقك وتفهمك لك  منى كل التقدير والاحترام

بالسبة للرسالة اثتاء الحفظ ليس له علاقة بالكود ولكن من خصائص اعدادات الاكسل وقد تم معالجتها

 

قوائم لجان الدور الثاني اولي.xlsb