ترحيل بيانات إلى جداول

[مجاهد2013]

السلام عليكم

أرجو المساعدة في ترحيل بيانات من شيت جدول عام ( يحتوي توقيت الأساتذة حسب الأقسام ) إلى شيت جدول فردي بحيث مثلا أستاذ ريا م1 ماهو القسم الدي يعمل معه أول حصة يوم الأحد هو قسم 3ت ر ( الأقسام موجودة في E6:Z6 )

استاذ.xlsx

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

جرب هذا الملف التسميات  ( ..... RG_1,RG_2) تجدها داخل الملف     Named Range

الماكرو المستعمل

Sub fil_table()
Dim i%, t%, k%
Dim MAIN_RG As Range
Set MAIN_RG = Range("B9:F16")
Dim VAR_RG As Range
Set VAR_RG = Range("B7:F7")
Dim RG_Saech As Range
Dim My_MATCH As Range
Dim COL%
Range("B9:F16").ClearContents
For k = 1 To 5
 Select Case k
     Case 1
     Set RG_Saech = Sheets("جدول عام").Range("RG_1")
     Case 2
     Set RG_Saech = Sheets("جدول عام").Range("RG_2")
     Case 3
     Set RG_Saech = Sheets("جدول عام").Range("RG_3")
     Case 4
     Set RG_Saech = Sheets("جدول عام").Range("RG_4")
     Case 5
     Set RG_Saech = Sheets("جدول عام").Range("RG_5")
 End Select
 For i = 9 To 16
   t = i - 8
 Set My_MATCH = RG_Saech.Rows(t)
 COL = Sheets("جدول عام").Range("b6:Z6").Find(Sheets("جدول فردي").Range("F6")).Column
 MAIN_RG.Cells(t, k) = Intersect(My_MATCH, Sheets("جدول عام").Cells(6, COL).Resize(62))
  Next
 Next
End Sub

الملف مرفق

 

 

OUSTAZ.xlsm

[مجاهد2013]

السلام عليكم أخ سليم

ليس ذاك المقصود فقد أرفقت ملفا توضيحيا

عند جلب اسم الاستاذ و مادة تدريسه يملا الجدول اليا باسماء الأقسام الموجودة في الصف 6 (E6:Z6) بناء على المنصب مثلا (ريا م1) الأقسام التي تقابله في الجدول العام و قد لونت الخلايا المناسبة لذلك بلون أصفر .ليوم الأحد كمثال

و شكرا

توضيح.xlsx

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

تم التعديل على الماكرو ليتناسب مع المطلوب 

كل ما عليك هو اختيار اسم الاستاذ  من الكومبو 1  او اسم المادة من الكومبو 2

Option Explicit

Private Sub ComboBox1_Change()
 get_data_Prof
End Sub
'++++++++++++++++++++++++++++++++

Private Sub ComboBox2_Change()
get_data_Matiere
End Sub
'+++++++++++++++++++++++++++++++++++++

Private Sub Worksheet_Activate()
fil_combo
End Sub
'====================================
Sub fil_combo()
Dim dic As Object, dic2
Dim cel As Range
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")

 '===========================
 For Each cel In Sheets("جدول عام").Range("c66:c85")
 If Not dic.exists(cel.Value) And cel <> "" Then
 dic.Add cel.Value, ""
 dic2.Add cel.Offset(, -1).Value, ""
 End If
 Next
 '===========================
 For Each cel In Sheets("جدول عام").Range("i66:i85")
 If Not dic.exists(cel.Value) And cel <> "" Then
 dic.Add cel.Value, ""
 dic2.Add cel.Offset(, -1).Value, ""
 End If
 Next
 ComboBox1.List = dic.keys
 ComboBox2.List = dic2.keys
 ComboBox1.BackColor = RGB(135, 255, 204)
 ComboBox2.BackColor = RGB(135, 255, 204)
 dic.RemoveAll: Set dic = Nothing
 dic2.RemoveAll: Set dic2 = Nothing
End Sub
'+++++++++++++++++++++++++++++++++++++++++++
Sub get_data_Prof()
Dim Am As Worksheet: Set Am = Sheets("جدول عام")
Dim Fr As Worksheet: Set Fr = Sheets("جدول فردي")
Dim Rg_to_copy As Range
Dim Start_Col%: Start_Col = 2
Dim Start_Row%: Start_Row = 9
Dim k%, x%, i%
Fr.Range("B9:f12").ClearContents
Fr.Range("B14:f17").ClearContents
   With Am
    .Range("c7:z14").Name = "Rg_1"
    .Range("c15:z22").Name = "Rg_2"
    .Range("c23:z30").Name = "Rg_3"
    .Range("c31:z38").Name = "Rg_4"
    .Range("c39:z46").Name = "Rg_5"
  End With
 For k = Start_Col To 6
  Set Rg_to_copy = Am.Range("Rg_" & k - 1)
   For i = 1 To Rg_to_copy.Rows.Count
   On Error Resume Next
     x = Rg_to_copy.Rows(i).Find(Fr.Range("f6")).Column
    On Error GoTo 0
        If x Then
            Cells(Start_Row, k) = Fr.Range("f6")
        End If
         Start_Row = Start_Row + 1
      If Start_Row = 13 Then Start_Row = 14
     x = 0
     Next i
     Start_Row = 9
   Next k

 End Sub
 '++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub get_data_Matiere()
Dim Am As Worksheet: Set Am = Sheets("جدول عام")
Dim Fr As Worksheet: Set Fr = Sheets("جدول فردي")
Dim Rg_to_copy As Range
Dim Start_Col%: Start_Col = 2
Dim Start_Row%: Start_Row = 30
Dim k%, x%, i%
Fr.Range("B30:f33").ClearContents
Fr.Range("B35:f38").ClearContents
   With Am
    .Range("c7:z14").Name = "Rg_1"
    .Range("c15:z22").Name = "Rg_2"
    .Range("c23:z30").Name = "Rg_3"
    .Range("c31:z38").Name = "Rg_4"
    .Range("c39:z46").Name = "Rg_5"
  End With
 For k = Start_Col To 6
  Set Rg_to_copy = Am.Range("Rg_" & k - 1)
   For i = 1 To Rg_to_copy.Rows.Count
   On Error Resume Next
     x = Rg_to_copy.Rows(i).Find(Fr.Range("F27")).Column
    On Error GoTo 0
        If x Then
            Cells(Start_Row, k) = Fr.Range("B27")
        End If
         Start_Row = Start_Row + 1
      If Start_Row = 34 Then Start_Row = 35
     x = 0
     Next i
     Start_Row = 33
   Next k
 End Sub

 

NEW_Repport.xlsm

[مجاهد2013]

عذرا استاذ سليم على الازعاج و لكن المطلوب داخل الجدول الأقسام المقابلة لمنصب ريا م1 في صف الاقسام

أرفقت لك ملف توضيحي

عندما أغير الأستاذ يتغير الجدول بما فيه من اقسام ربما : 3ع ت01 و 2ت ر 1ع2

............

salim.xlsx