ترحيل الدرجات

[فوزى فوزى]

ممكن كود ترحيل يرحل الدرجة بشرط الاسم والمادة الى شيت الدور الثانى موجود نموذج للحل داخل الشيت

ترحيل درجات.xlsm

[lionheart]

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, dic As Object, s As String, t As String, i As Long, c As Long
    Set ws = ThisWorkbook.Worksheets(1): Set sh = ThisWorkbook.Worksheets(2)
    Set dic = CreateObject("Scripting.Dictionary")
    a = ws.Range("A3").CurrentRegion.Value
    For i = LBound(a) + 1 To UBound(a)
        s = a(i, 2) & Chr(2) & a(i, 3)
        If Not dic.Exists(a(i, 1)) Then dic.Add s, a(i, 4)
    Next i
    For i = 2 To sh.Cells(Rows.Count, "B").End(xlUp).Row
        For c = 3 To 8
            t = sh.Cells(i, 2).Value & Chr(2) & sh.Cells(3, c).Value
            If dic.Exists(t) Then sh.Cells(i, c).Value = dic(t)
        Next c
    Next i
End Sub

 

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

يمكنك استعمال هذا الاجراء

Sub tr7eel()
For r = 4 To Cells(Rows.Count, 2).End(3).Row
r2 = Evaluate("=MATCH(B" & r & ",'الدور الثانى'!B:B,0)")
c2 = Evaluate("=MATCH(C" & r & ",'الدور الثانى'!3:3,0)")
Sheet2.Cells(r2, c2) = Range("d" & r)
Next r
MsgBox "Done by mr-mas.com"
End Sub

بالتوفيق

[فوزى فوزى]

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

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

آمين ولك مثل ما دعوت وزيادة