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

جدول حصص


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

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

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

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

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

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

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

اخي محمد

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

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

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

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

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

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

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

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

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

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

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

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

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

 

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

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

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

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

 

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

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

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

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

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

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

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

 

 

ترحيل البيانات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

 

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

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

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

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

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

 

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

  • 1 year later...

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

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information