اذهب الي المحتوي
أوفيسنا

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


amr_ha2003
إذهب إلى أفضل إجابة Solved by أ / محمد صالح,

الردود الموصى بها

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

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

Book1.xlsx

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

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

  • Like 1
رابط هذا التعليق
شارك

  • أفضل إجابة

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

بالتوفيق

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

  • Like 2
رابط هذا التعليق
شارك

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

بالتوفيق

  • Like 1
رابط هذا التعليق
شارك

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

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

            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

بالتوفيق

  • Like 2
رابط هذا التعليق
شارك

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

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

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

بالتوفيق

 

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

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

 

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information