تعديل على كود

[عطية23]

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

المطلوب ان يرحل اكثر من عمودين ولكم الشكر

توزيع التلاميذ على الفصول.xlsm

[محمد حسن المحمد]

السلام عليكم ورحمة الله وبركاته

أرجو أن تنظر في هذا الحل 

توزيع التلاميذ على الفصول.xlsm

[عطية23]

استاذنا الغالى بارك الله فيك وبارك لك في ذريتك وجعله الله في ميزان حسناتك

[محمد حسن المحمد]

آمين يا رب العالمين ولكم بمثل ما دعوتم أخي الكريم

حياكم الله

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

[a.kawkab]

السلام عليكم

بعد اذن الاستاذ محمد حسن المحمد

تفضل اخى عطيىة23

تعديل على كود الاستاذ الفاضل ياسر خليل كما طلبت

Sub Test()
    Dim a, v, ws As Worksheet, sh As Worksheet, lr As Long, i As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets(1)
        Set sh = ThisWorkbook.Worksheets(2)
        v = sh.Range("k1").Value
        If v = Empty Or Not IsNumeric(v) Then MsgBox "Enter Proper Grade First", vbExclamation: Exit Sub
        lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
        a = ws.Range("B4:g" & lr).Value
        ReDim b(1 To UBound(a), 1 To 6)
        For i = LBound(a) To UBound(a)
            If a(i, 6) = v Then
                k = k + 1
                b(k, 1) = k
                b(k, 2) = a(i, 1)
                b(k, 3) = a(i, 2)
                b(k, 4) = a(i, 3)
                b(k, 5) = a(i, 4)
                b(k, 6) = a(i, 5)
            End If
        Next i
        If k > 0 Then
            sh.Range("A7:g" & Rows.Count).ClearContents
            sh.Range("A7").Resize(k, UBound(b, 2)).Value = b
        End If
    Application.ScreenUpdating = True
End Sub

 

توزيع التلاميذ على الفصول.xlsm

[عطية23]

الشكر للاستاذ الفاضل جهد مشكور لحضرتك جعله الله في ميزان حسناتك

الف شكر استاذانا كواكب