محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر

[ehabaf2]

السلام عليكم الاساتذة الكرام

محتاج كود ترحيل تقيم الطلاب من جدول الى جدول اخر

مرفق ملف التقيم

ترحيل ورش.xlsx

[ehabaf2]

السلام عليكم الاساتذة الافاضل

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

وشكرا على مجهودكم

[حسونة حسين]

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

تفضل اخى

Option Explicit

Sub Tarhil()
    Dim WS As Worksheet, SH As Worksheet, ARR, LR As Long, P As Long, i As Long, J As Long, K As Long, R As Range
    Set WS = ThisWorkbook.Worksheets("التسجيل")
    Set SH = ThisWorkbook.Worksheets("التقيم")
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    P = 1
    ARR = WS.Range("A10:R" & WS.Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim Temp(1 To LR + 1, 1 To UBound(ARR, 2))
    For i = 1 To UBound(ARR)
        For J = 5 To 15
            If ARR(i, J) <> "" Then
                Temp(P, 1) = WorksheetFunction.Max(Columns("AM")) + P
                For K = 2 To 18
                    Temp(P, K) = ARR(i, K)
                Next K

                If R Is Nothing Then
                    Set R = WS.Cells(i + 9, 1)
                Else
                    Set R = Union(R, WS.Cells(i + 9, 1))
                End If

                P = P + 1
                Exit For
            End If
        Next J
    Next i
    If Not R Is Nothing Then R.EntireRow.Delete
    With SH
        If P > 0 Then
            .Columns("AP").NumberFormat = "@"
            .Columns("BC").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
            LR = Application.Max(2, .Cells(Rows.Count, "AM").End(xlUp).Row)
            .Range("AM" & LR).Resize(P - 1, UBound(Temp, 2)).Value = Temp
        End If
    End With
End Sub

 

[ehabaf2]

السلام عليكم استاذنا الفاضل حسونة حسين

الف الف شكر على مجهود حضرتك و لكن كالعادة انا مقصر فى شرح المطلوب 

يوجد بعض الملاحظات فى الكود

الاول عند ترحيل تقيم الطلاب يتم مسح درجات التقيم فقط من العمود F الى العمود O و لا يتم مسح بيانات الطلاب و كذلك يتم ترحيل الطالب الغائب المسجل غ

ثانيا يتم الترحيل الى الاعمدة من العمود AM الى العمود BC و لا يتم مسح ما تم ترحيله عند تكرار الترحيل 

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

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

اكرر شكر لحضرتك على الاهتمام والمساعدة

تم تعديل أغسطس 8, 2023 بواسطه ehabaf2

[lionheart]

Try this code

Sub Test()
    Dim ws As Worksheet, r As Long, lr As Long, i As Long, j As Long, m As Long
    Application.ScreenUpdating = False
        Set ws = Sheet1
        ReDim a(1 To 1000, 1 To 17)
        With ws
            lr = .Cells(Rows.Count, "B").End(xlUp).Row
            For r = 10 To lr
                If Application.WorksheetFunction.CountBlank(.Range("E" & r).Resize(, 11)) <> 11 Then
                    i = i + 1
                    For j = 2 To 18
                        a(i, j - 1) = .Cells(r, j).Value
                    Next j
                End If
            Next r
            If i > 0 Then
                m = .Cells(Rows.Count, "AM").End(xlUp).Row + 1
                m = IIf(m = 5, 9, m)
                .Range("AM" & m).Resize(i, UBound(a, 2)).Value = a
                Application.Goto .Range("AM" & m), True
            End If
        End With
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

[ehabaf2]

 السلام عليكم استاذ lionheart الكود يعمل و ينفذ المطلوب الحمد لله و الف شكر لحضرتك و لكن ينقصه فقط مسح البيانات التى تم ترحيها يعني مسح درجات التقيم فقط من العمود F الى العمود O 

اكرر شكري لحضرتك

[lionheart]

It is just one line of code and you can do it yourself. Refer to the desired range using Range property like that

Range("A1:C10")

Of course change the reference to the reference you need then use ClearContents method

so the line should look like that

Range("A1:C10").ClearContents

 

The line will be added to the end of the code after trasnferring data before this line

Application.Goto .Range("AM" & m), True

 

Don't forget to change the reference A1 to C10 to the range you desire to clear its contents

which should be F10:O & the last row (lr variable)

[ehabaf2]

الاستاذ الفاضل lionheart

الحمدلله حمدا كثيرا طيبا مبارك فيه عرفت اعدل الكود و كنت فى قمة السعادة لانني عرفت اعدل الكود و الكود اشتغل و نفذ المطلوب بشكل رائع

سلمت يداك و زادك الله من فضله و علمه

الف الف شكر لجميع السادة الاساتذة الافاضل و القائمين على الموقع

ملحوظة انا لم استخدم هذا الجزء و لم اعرف فيما يستخدم

Application.Goto .Range("AM" & m), True

[حسونة حسين]

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

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

عند ترحيل تقيم الطلاب يتم مسح درجات التقيم فقط من العمود F الى العمود O و لا يتم مسح بيانات الطلاب

تفضل هذا التعديل

Option Explicit

Sub Tarhil()
    Dim WS As Worksheet, ARR, LR As Long, P As Long, i As Long, J As Long, K As Long
    Set WS = ThisWorkbook.Worksheets("التسجيل")
    P = 1
    LR = WS.Range("A" & Rows.Count).End(xlUp).Row
    ARR = WS.Range("B10:R" & LR).Value
    ReDim Temp(1 To LR + 1, 1 To UBound(ARR, 2))
    
    For i = 1 To UBound(ARR)
        For J = 5 To 15
            If ARR(i, J) <> "" Then
                For K = 1 To 17
                    Temp(P, K) = ARR(i, K)
                Next K
                P = P + 1
                Exit For
            End If
        Next J
    Next i

    With WS
        If P > 0 Then
            .Range("F10:O" & LR).ClearContents
            .Columns("AP").NumberFormat = "@"
            .Columns("BC").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
            LR = Application.Max(9, .Cells(.Rows.Count, "AM").End(xlUp).Row)
            .Range("AM" & LR + 1).Resize(P - 1, UBound(Temp, 2)).Value = Temp
        End If
    End With
End Sub

 

2 ساعات مضت, ehabaf2 said:

ملحوظة انا لم استخدم هذا الجزء و لم اعرف فيما يستخدم

Application.Goto .Range("AM" & m), True

جعل مرشر الماوس يذهب الي اول خليه تم ترحيلها في العامود AM

[lionheart]

This line

Application.Goto .Range("AM" & m), True

is used to go to specific range. At the end of the code if the transfer process happens, excel will go to column AM at the row m

so it is useful to see the results of the code

[ehabaf2]

الاستاذ الفاضل حسونه حسين

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

run-time error 9

 

[ehabaf2]

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

الف شكر م حسونة حسين على تعب حضرتك 

الكود يعمل و ينفذ المطلوب 

اكرر شكرى لحضرتك

تم تعديل أغسطس 9, 2023 بواسطه ehabaf2