مطلوب كود لترحيل البيانات من ورقة الفصول الى ورقة الاستاذ

[dr.Mo7amed]

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

من ورقة الفصول الى ورقة الاستاذ

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

ترحيل لجدول الاستاذ.rar

[ابراهيم الحداد]

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

انسخ هذا الكود وضعه فى موديول وخصص له زر

ملحوظة هامة : ان لم تتطابق معك الاسماء فى الجدولين لن يعمل معك الكود بكفاءة

Sub TransData()
Dim Fsl As Worksheet, Tec As Worksheet
Dim cel As Range
Dim x As Integer, y As Integer
Set Fsl = Sheets("fsol")
Set Tec = Sheets("teacher")
For Each cel In Fsl.Range("C6:G15")
x = cel.Row
y = cel.Column
If cel.Value = Tec.Range("C2") Then
Tec.Cells(x, y) = Fsl.Range("C2")
Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value
End If
Next
End Sub

 

[dr.Mo7amed]

نسخت الكود ووضعته في مووديل لكن لم يظبط معي

هل هناك معادلة توضع أو شيء لاني وضعت الكود ولم يظبط معي

 

جزاكم الله خيرا استاذ زيزو

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit

Sub Give_Data()
Dim r, c As Integer
Dim Rfsol, Rteacher, Cel As Range
Dim My_name As String

Set Rfsol = Sheets("fsol").Range("c6:g15")
Set Rteacher = Sheets("teacher").Range("c6:g15")
Rteacher.ClearContents

My_name = Sheets("teacher").Range("c2")
For Each Cel In Rfsol
    If Cel = My_name Then
        r = Cel.Row: c = Cel.Column
        Sheets("teacher").Cells(r, c).Offset(-1, 0) = Cel.Offset(-1, 0)
        Sheets("teacher").Cells(r, c) = Cel
    End If
 Next
End Sub

 

[dr.Mo7amed]

استاذ سليم واستاذ زيزو جزاكم الله خيرا

هل ممكن وضع الكود في الملف المرفق لان خبرتي قليله في الاكواد

وجزاكم الله عنا خير الجزاء

ترحيل لجدول الاستاذ.rar

[سليم حاصبيا]

16 دقائق مضت, dr.Mo7amed said:

استاذ سليم واستاذ زيزو جزاكم الله خيرا

هل ممكن وضع الكود في الملف المرفق لان خبرتي قليله في الاكواد

وجزاكم الله عنا خير الجزاء

ترحيل لجدول الاستاذ.rar

نظراً الى ان الاخ زيزو وضع لك نفس الكود تقريباً

احببت ان اغير الى هذا الكود

Option Explicit

Sub Give_Data1()

Dim Rfsol, Rteacher, Cel As Range
Dim My_name As String
Dim adr, adr1 As String
 
Set Rfsol = Sheets("fsol").Range("c6:g15")
Set Rteacher = Sheets("teacher").Range("c6:g15")
Rteacher.ClearContents

My_name = Sheets("teacher").Range("c2")
    For Each Cel In Rfsol
         If Cel = My_name Then
            adr = Cel.Address: adr1 = Cel.Offset(-1, 0).Address
            Sheets("teacher").Range(adr) = Cel
            Sheets("teacher").Range(adr1) = Cel.Offset(-1, 0)
        End If
     Next
End Sub

الملف مرفق

 

ترحيل لجدول salimالاستاذ.rar

[dr.Mo7amed]

الله يجزاك خير استاذ سليم

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

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

وهل يمكن تعديل الكود لكي يعمل بدون زر ؟

ولو تم اضافة فصل جديد فهل الكود يرحل منه لنفس الاستاذ ؟

واعتذر عن قلة خبرتي والاطالة

وجزاكم الله عنا خيرا

تم تعديل يونيو 7, 2017 بواسطه dr.Mo7amed