جدول حصص

[dr.Mo7amed]

برجاء التكرم بمساعدتي في معادلات او كود  لاستدعاء مواد الاستاذ والفصول الى جدول الاستاذ

مع ملاحظة ان الاستاذ يعطي اكثر من مادة وفي اكثر من فصل

وكل عام وحضراتكم بخير

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

استدعاء البيانات لجدول الاستاذ.rar

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

اخي محمد

البرنامج الذي رفعته هو لفصل واحد و لبس هناك وقت لتعبئة نموذج لكل الفصول

الرجاء عمل برنامج متكامل (كل شيت يحتوي على فصل واحد في نفس نطاق الخلايا مثلا من C6 لغاية G15 )

حاول عدم استعمال الخلايا المدمجة

لتكن اسماء الاساتذة بدون القاب (محمد مثلاً و ليس أ.مجمد)

و اخيراً ضع قائمة بأسماء الاساتذة في اي مكان من الشيت Teachers( كي يسهل العمل)

اذا صادف وجود استاذين ينفس الاسم يجب التمييز بينهما باسم العائلة

[dr.Mo7amed]

اخي الحبيب سليم

والله اعتذر بشده لاني اشغلتك واثقلت عليك ارجو منك أن تسامحني

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

والمطلوب المساعدة في  :  أن يتم ترحيل اسم المادة ورقم الفصل في جدول الاستاذ
 مثلا: في خانة المادة [ جبر ] و في خانة الفصل  [ فصل 5/ب] وبالتالي جدول الاستاذ يتضمن كل المواد التي يدرسها في الفصول الموجودة في الشيت المرفق على اعتبار أن الاستاذ يدرس أكثر من مادة لعدة فصول

وفقنا الله وإياكم لفعل الخير

وادعوا الله في هذا الشهر الفضيل أن يتقبل منا ومنكم صالح الأعمال

 

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

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

ربما كان هذا المطلوب

يمكنك زيادة عدد الشيتات كما تشاء(نفس التنسيق  بالنسبة للنطاقات شرط ان تبقى الشيت teachers هي الاولى)

 

ترحيل البياناتsalim1.rar

[dr.Mo7amed]

جزاكم الله خيرا على مجهودك حبيبنا

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

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

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

جعله الله في ميزان حسناتكم 

 

 

ترحيل البياناتsalim1.rar

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

اخى الكريم

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

بعد اذن الاستاذ سليم

جرب هذا الكود

Sub TransData()
Dim Fsl As Worksheet, Tec As Worksheet
Dim cel As Range
Dim x As Integer, y As Integer, i As Integer
For i = 1 To Sheets.Count
If Sheets(i).Name <> "teachers" Then
Set Fsl = Sheets(i)
Set Tec = Sheets("teachers")
For Each cel In Fsl.Range("C6:G15")
x = cel.Row
y = cel.Column
If cel.Value = Tec.Range("D2") Then
Tec.Cells(x, y) = Fsl.Range("D2")
Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value
End If
Next
End If
Next

End Sub

 

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

1 ساعه مضت, dr.Mo7amed said:

جزاكم الله خيرا على مجهودك حبيبنا

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

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

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

جعله الله في ميزان حسناتكم 

 

 

ترحيل البياناتsalim1.rar

استبدل الكود بهذا

Option Explicit
Sub Give_Data()

Dim My_Sh As Worksheet
Dim My_Rg, cel As Range
Dim My_Adr As String
Dim k, x As Integer
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
Sheets("teachers").Range("c6:g15").ClearContents
k = Sheets.Count - 1

For x = 2 To k
Set My_Sh = Sheets(x)
Set My_Rg = My_Sh.Range("c6:g15")

  For Each cel In My_Rg.Cells
  If cel = Sheets("teachers").Range("d2") Then
  My_Adr = cel.Address
  
   With Sheets("teachers").Range(My_Adr)
        .Value = Mid(Trim(My_Sh.Range("d2")), 5, 10)
        .Offset(-1, 0) = cel.Offset(-1, 0)
   End With
      
   End If
  Next
Next
With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

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

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

معذرة اخى الكريم محمد

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

Sub TransData()
Dim Fsl As Worksheet, Tec As Worksheet
Dim cel As Range
Dim x As Integer, y As Integer, i As Integer
Set Tec = Sheets("teachers")
Tec.Range("C6:G15").ClearContents
For i = 1 To Sheets.Count
If Sheets(i).Name <> "teachers" Then
Set Fsl = Sheets(i)
For Each cel In Fsl.Range("C6:G15")
x = cel.Row
y = cel.Column
If cel.Value = Tec.Range("D2") Then
Tec.Cells(x, y) = Fsl.Range("D2")
Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value
End If
Next
End If
Next

End Sub

 

[dr.Mo7amed]

2 hours ago, سليم حاصبيا said:

ربما كان هذا المطلوب

يمكنك زيادة عدد الشيتات كما تشاء(نفس التنسيق  بالنسبة للنطاقات شرط ان تبقى الشيت teachers هي الاولى)

 

ترحيل البياناتsalim1.rar

 

26 minutes ago, سليم حاصبيا said:

استبدل الكود بهذا

Option Explicit
Sub Give_Data()

Dim My_Sh As Worksheet
Dim My_Rg, cel As Range
Dim My_Adr As String
Dim k, x As Integer
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
Sheets("teachers").Range("c6:g15").ClearContents
k = Sheets.Count - 1

For x = 2 To k
Set My_Sh = Sheets(x)
Set My_Rg = My_Sh.Range("c6:g15")

  For Each cel In My_Rg.Cells
  If cel = Sheets("teachers").Range("d2") Then
  My_Adr = cel.Address
  
   With Sheets("teachers").Range(My_Adr)
        .Value = Mid(Trim(My_Sh.Range("d2")), 5, 10)
        .Offset(-1, 0) = cel.Offset(-1, 0)
   End With
      
   End If
  Next
Next
With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

ما شاء الله تبارك الله الكود ضبط بالفعل

ولكن هل هناك مجال في أن تجمع ورقات الفصول في ورقة واحدة بدلا من 3 ورقات

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

C6:G12

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

ترحيل البياناتsalim1.rar

[dr.Mo7amed]

1 hour ago, زيزو العجوز said:

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

معذرة اخى الكريم محمد

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

Sub TransData()
Dim Fsl As Worksheet, Tec As Worksheet
Dim cel As Range
Dim x As Integer, y As Integer, i As Integer
Set Tec = Sheets("teachers")
Tec.Range("C6:G15").ClearContents
For i = 1 To Sheets.Count
If Sheets(i).Name <> "teachers" Then
Set Fsl = Sheets(i)
For Each cel In Fsl.Range("C6:G15")
x = cel.Row
y = cel.Column
If cel.Value = Tec.Range("D2") Then
Tec.Cells(x, y) = Fsl.Range("D2")
Tec.Cells(x, y).Offset(-1, 0).Value = cel.Offset(-1, 0).Value
End If
Next
End If
Next

End Sub

 

ما شاء الله يا استاذ زيزو الكود ظبط يتبقى فقط توسعة نطاق الخلية

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

C6:G12

ترحيل البيانات زيزو.rar

[فتحي حامد]

في 6/8/2017 at 16:03, dr.Mo7amed said:

ما شاء الله يا استاذ زيزو الكود ظبط يتبقى فقط توسعة نطاق الخلية

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

C6:G12

ترحيل البيانات زيزو.rar

كيف يمكن زيادة الفصول بنفس المنوال

 

[يحي هلالي الهادي]

السلام عليكم و بغد هذا الموضوع الذي كنت ابجث عنه ارجو المزيد من التوضيح مع اظهار الالمعادلات و شكرا