كود ترحيل بيانات من شيت الى شيت أخر

[allaoua10]

السلام عليكم اطلب مساعدتكم يااعضاء المنتدى في طلب تحويل بيانات اي كود ترحيل من شيت الى شيت اخر وشكرا مسبقا

مواقيت الاساتذة.xlsm

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

جرب هذا الكود

1-دائماً وأبداً تسمية الشيتات باللغة الأجنبية    لحسن عمل الكود ونسخه ولصقه والابتعاد قدر الامكان عن الخلايا المدمجة

Option Explicit
Sub find_Prof()
Dim A, itm
Dim Ad1$, Ad2$
Dim F_rg As Range
Dim Find_what
Dim Ak As Worksheet, Pr As Worksheet
Dim Clas$
Dim col
Set Ak = Sheets("Akssam")
Set Pr = Sheets("Prof")
Pr.Range("E8:I29").ClearContents
A = Array("محمود", "علي", "عمر", "مصطفى")
 For Each itm In A
  Set F_rg = Ak.Range("D8:M29").Find(itm, lookat:=1)
   If Not F_rg Is Nothing Then
     Ad1 = F_rg.Address: Ad2 = Ad1
    Do
      Select Case F_rg.Row
        Case Is <= 18: Clas = "4م1 ف1"
        Case Is <= 19: Clas = "4م1 ف2"
      End Select
      
      Select Case F_rg.Column
        Case 5: col = 5
        Case 7: col = 6
        Case 9: col = 7
        Case 11: col = 8
        Case 13: col = 9
      End Select
      
      Pr.Cells(F_rg.Row, col) = F_rg & " /  " & F_rg.Offset(, -1) _
       & ": " & Clas

     Set F_rg = Ak.Range("D8:M29").FindNext(F_rg)
     Ad2 = F_rg.Address
     If Ad1 = Ad2 Then Exit Do
    Loop
  End If
 Next
End Sub

الملف مرفق

allaoua.xlsm

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

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

Option Explicit
Sub find_Prof()
Dim A, i%, X%
Dim First_Address$, Current_Address$
Dim F_rg As Range
Dim Optional_rg As Range
Dim Plage_E As Range, Plage_F As Range
Dim Plage_G As Range, Plage_H As Range
Dim Plage_I As Range, Plage_Match As Range
Dim Ak As Worksheet, Pr As Worksheet
Dim Clas$

Set Ak = Sheets("Akssam")
Set Pr = Sheets("Prof")
Pr.Range("E8:I84").ClearContents
A = Array("محمود", "علي", "مصطفى", "عمر", "نورة", "عدي", "زيد")
 For i = 0 To UBound(A)
        Set Plage_Match = Pr.Range("D8:D18").Offset(i * 11)
        Set Plage_E = Pr.Range("E8:E18").Offset(i * 11)
        Set Plage_F = Pr.Range("F8:F18").Offset(i * 11)
        Set Plage_G = Pr.Range("G8:G18").Offset(i * 11)
        Set Plage_H = Pr.Range("H8:H18").Offset(i * 11)
        Set Plage_I = Pr.Range("I8:I18").Offset(i * 11)
        Set F_rg = Ak.Range("D8:M29").Find(A(i), lookat:=1)
   If Not F_rg Is Nothing Then
        First_Address = F_rg.Address
        Current_Address = First_Address
    Do
          Select Case F_rg.Row
            Case Is <= 18: Clas = "4م1 ف1"
            Case Is <= 19: Clas = "4م1 ف2"
          End Select
          
          Select Case F_rg.Column
            Case 5:   Set Optional_rg = Plage_E
            Case 7:   Set Optional_rg = Plage_F
            Case 9:   Set Optional_rg = Plage_G
            Case 11:  Set Optional_rg = Plage_H
            Case 13:  Set Optional_rg = Plage_I
          End Select
           
           X = Application.Match(Ak.Cells(F_rg.Row, 3), Plage_Match, 0)
            Optional_rg.Cells(X) = F_rg & " /  " & F_rg.Offset(, -1) _
             & ": " & Clas
            Set F_rg = Ak.Range("D8:M29").FindNext(F_rg)
            Current_Address = F_rg.Address
            If First_Address = Current_Address Then Exit Do
        
    Loop
   
   
   End If 'for F_rg
 Next i

End Sub
 

الملف مرفق (عسى ان ينال الإعجاب)

allaoua_Super.xlsm

[allaoua10]

شكرا جزيلا بارك الله فيك .