برجاء المساعدة فى اسلوب ترحيل البيانات

[amr_ha2003]

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

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

Book1.xlsx

[أ / محمد صالح]

هل معنى أن امتداد الملف xlsx أنك تريد تنفيذ المطلوب بالمعادلات؟

[amr_ha2003]

 اريد تنفيذ المطلوب بالمعادلات على الملف المرفق

ولكم جزيل الشكر 

 

 

 

[أ / محمد صالح]

إن شاء الله يكون هذا هو المطلوب

بالتوفيق

ترحيل درجات الطلاب بأسلوب مختلف.xlsx

[lionheart]

Sub Test()
    Dim x, ws As Worksheet, sh As Worksheet, r As Long, m As Long, c As Long, n As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("2")
        With sh.Range("B2").CurrentRegion.Offset(1)
            .Cells.UnMerge: .ClearContents
        End With
        m = 3
        For r = 4 To ws.Cells(Rows.Count, "B").End(xlUp).Row
            sh.Cells(m, 2).Resize(, 2).Value = ws.Cells(r, 2).Resize(, 2).Value
            n = 4
            For c = 4 To 10 Step 2
                sh.Cells(m, n).Value = ws.Cells(r, c).Value
                sh.Cells(m + 1, n).Value = ws.Cells(r, c + 1).Value
                n = n + 1
            Next c
            sh.Cells(m, 8).Value = ws.Cells(r, 12).Value
            For Each x In Array(2, 3, 8)
                sh.Cells(m, x).Resize(2).Merge
            Next x
            m = m + 2
        Next r
    Application.ScreenUpdating = True
End Sub

 

[أ / محمد صالح]

أعتقد أن صاحب الاستفسار حدد طريقة المطلوب

بالمعادلات وليس الكود

بالتوفيق

[lionheart]

I didn't see that point when started to work on the problem. Generally, it will not be harmful to let the OP try the code too

[أ / محمد صالح]

لا يوجد مشكلة في إثراء الموضوع

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

            sh.Cells(m, 8).Value = ws.Cells(r, 12).Value
            sh.Cells(m, 9).Value = ws.Cells(r, 13).Value
            For Each x In Array(2, 3, 8, 9)

ليصبح الكود كاملا

Sub Test()
    Dim x, ws As Worksheet, sh As Worksheet, r As Long, m As Long, c As Long, n As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("2")
        With sh.Range("B2").CurrentRegion.Offset(1)
            .Cells.UnMerge: .ClearContents
        End With
        m = 3
        For r = 4 To ws.Cells(Rows.Count, "B").End(xlUp).Row
            sh.Cells(m, 2).Resize(, 2).Value = ws.Cells(r, 2).Resize(, 2).Value
            n = 4
            For c = 4 To 10 Step 2
                sh.Cells(m, n).Value = ws.Cells(r, c).Value
                sh.Cells(m + 1, n).Value = ws.Cells(r, c + 1).Value
                n = n + 1
            Next c
            sh.Cells(m, 8).Value = ws.Cells(r, 12).Value
            sh.Cells(m, 9).Value = ws.Cells(r, 13).Value
            For Each x In Array(2, 3, 8, 9)
                sh.Cells(m, x).Resize(2).Merge
            Next x
            m = m + 2
        Next r
    Application.ScreenUpdating = True
End Sub

بالتوفيق

[amr_ha2003]

1 hour ago, أ / محمد صالح said:

أعتقد أن صاحب الاستفسار حدد طريقة المطلوب

بالمعادلات وليس الكود

بالتوفيق

 

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

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

 

[أ / محمد صالح]

جميعا بإذن الله