allaoua10 قام بنشر ديسمبر 19, 2020 مشاركة قام بنشر ديسمبر 19, 2020 السلام عليكم اطلب مساعدتكم يااعضاء المنتدى في طلب تحويل بيانات اي كود ترحيل من شيت الى شيت اخر وشكرا مسبقا مواقيت الاساتذة.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر ديسمبر 19, 2020 مشاركة قام بنشر ديسمبر 19, 2020 جرب هذا الكود 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 3 رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر ديسمبر 19, 2020 أفضل إجابة مشاركة قام بنشر ديسمبر 19, 2020 تم تعديل الكود ليعطي حصص كل استاذ منفرداً جسب الأيام والصف والتوقيت 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 3 1 رابط هذا التعليق شارك More sharing options...
allaoua10 قام بنشر ديسمبر 20, 2020 الكاتب مشاركة قام بنشر ديسمبر 20, 2020 شكرا جزيلا بارك الله فيك . رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان