كود ترحيل طلاب

[تهانى فكرى]

السادة خبراء الاكسيل بعد التحية

لو تكرمتم كنت اريد صياغة كود برمجى

لترحيل التلاميذ من صفحة الصف الثانى الى صفحة المحولون من المدرسة عند الضغط على زر تحويل الطالب مع مسح البيانات في الصفحة الرئيسية

سجل مستجدين - 2025.xlsm

[محمد هشام.]

اخي الفاضل صفحة الصف الثانى فارغة  زيادة انك لم تدكر لنا  ماهو النطاق او الاعمدة المرغوب ترحيلها 

يرجى اظافة بعض البيانات الوهمية على الملف مع ارفاق عينة للنتائج المتوقعة .ربما نستطيع مساعدتك

[تهانى فكرى]

اخى الفاضل اريد ترحيل بيانات كل الاعمدة بناء على اختيار العمود الاخير وهو التحويلات فاذا اخترت "من المدرسة " من القائمة المنسدلة يقوم بنقل بيانات الطالب من شيت الصف الثانى الى شيت محولون من المدرسة ولك جزيل الشكر اخى الكريم

سجل مستجدين - 2025.xlsm

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

[محمد هشام.]

تفضل اخي 

Option Explicit

Sub filtre()
Dim f$, Lastrow&, Cnt&, n&:   f = "من المدرسة"
Dim WS As Worksheet: Set WS = Sheets("الصف الثانى ")
Dim src As Worksheet: Set src = Sheets("محولين الى المدرسة")
Application.ScreenUpdating = False
src.Range("B10:U" & src.Rows.Count).ClearContents
Lastrow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row
For Cnt = 10 To Lastrow
    If UCase(WS.Range("V" & Cnt).Value) Like f Then
     n = n + 1
    src.Range("B" & n + 9 & ":U" & _
              n + 9).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value
  End If
Next
Application.ScreenUpdating = True
End Sub

 

لتنفيد الكود تلقائيا عند التغيير في عمود  التحويلات المدرسية (الصف الثانى )

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V10:V600")) Is Nothing Then
Application.EnableEvents = False
    Application.Run ("filtre")
Application.EnableEvents = True
   End If
End Sub

 

 

سجل مستجدين - 2025 V2.xlsm

تم تعديل يوليو 28 بواسطه محمد هشام.

[تهانى فكرى]

شكرا ليك مستر محمد على تعبك ، ربنا يبارك فيك 

[تهانى فكرى]

On 7/28/2024 at 6:17 PM, محمد هشام. said:

تفضل اخي 

Option Explicit

Sub filtre()
Dim f$, Lastrow&, Cnt&, n&:   f = "من المدرسة"
Dim WS As Worksheet: Set WS = Sheets("الصف الثانى ")
Dim src As Worksheet: Set src = Sheets("محولين الى المدرسة")
Application.ScreenUpdating = False
src.Range("B10:U" & src.Rows.Count).ClearContents
Lastrow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row
For Cnt = 10 To Lastrow
    If UCase(WS.Range("V" & Cnt).Value) Like f Then
     n = n + 1
    src.Range("B" & n + 9 & ":U" & _
              n + 9).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value
  End If
Next
Application.ScreenUpdating = True
End Sub

 

لتنفيد الكود تلقائيا عند التغيير في عمود  التحويلات المدرسية (الصف الثانى )

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V10:V600")) Is Nothing Then
Application.EnableEvents = False
    Application.Run ("filtre")
Application.EnableEvents = True
   End If
End Sub

 

 

سجل مستجدين - 2025 V2.xlsm 393.32 kB · 11 downloads

استاذ محمد الكود لا يعمل ولا يقوم بتحويل و نقل الاسماء

 

[محمد هشام.]

الكود يشتغل عندي بشكل جيد !!!!

اخي قم بغلق الملف وإعادة تشغيله مع محاول تنفيذ الكود مباشرة بعد إضافة عبارة من المدرسة على بعض الصفوف ووافينا بالنتيجة 

تم تعديل يوليو 30 بواسطه محمد هشام.

[تهانى فكرى]

ازاى اشغل الكود مباشر مش فاهمه

لما بضغط على تحويل طالب بتظهر رسالة x 400

[محمد هشام.]

 

8 ساعات مضت, تهانى فكرى said:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V10:V600")) Is Nothing Then
Application.EnableEvents = False
    Application.Run ("filtre")
Application.EnableEvents = True
   End If
End Sub

اخي الكود يتم تنفيده تلقائيا عند تغيير القيمة في عمود من / إلى المدرسة بمجرد اختيار عبارة من المدرسة يتم نقل العمود الهدف الى ورقة (محولين الى المدرسة) دون الحاجة لاستخدام الازرار 

اما ادا كنت تريد تنفيده فقط عند الظغط على زر تحويل الطالب  تفضل تم ربط الكود بالزر 

 

سجل مستجدين - 2025 V3.xlsm

[تهانى فكرى]

On 7/28/2024 at 6:17 PM, محمد هشام. said:

تفضل اخي 

Option Explicit

Sub filtre()
Dim f$, Lastrow&, Cnt&, n&:   f = "من المدرسة"
Dim WS As Worksheet: Set WS = Sheets("الصف الثانى ")
Dim src As Worksheet: Set src = Sheets("محولين الى المدرسة")
Application.ScreenUpdating = False
src.Range("B10:U" & src.Rows.Count).ClearContents
Lastrow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row
For Cnt = 10 To Lastrow
    If UCase(WS.Range("V" & Cnt).Value) Like f Then
     n = n + 1
    src.Range("B" & n + 9 & ":U" & _
              n + 9).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value
  End If
Next
Application.ScreenUpdating = True
End Sub

 

لتنفيد الكود تلقائيا عند التغيير في عمود  التحويلات المدرسية (الصف الثانى )

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V10:V600")) Is Nothing Then
Application.EnableEvents = False
    Application.Run ("filtre")
Application.EnableEvents = True
   End If
End Sub

 

 

سجل مستجدين - 2025 V2.xlsm 393.32 kB · 11 downloads

استاذ محمد الكود لا يعمل ولا يقوم بتحويل و نقل الاسماء

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

وشكرا

[تهانى فكرى]

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

[محمد هشام.]

اخي طريقة وشكل تصمييمك للملف لا تتناسب مع  طلبك الاخير سيتم حدف خلايا القوائم المنسدلة مع  فقدان التنسيقات والصيغ في الأعمدة المجاورة للجدول 

في حالة قمت بإعادة النظر في شكل الملف يمكنك استخدام الكود التالي 

Sub filtre2()
    Dim f$, lastRow&, Cnt&, n&, lr As Long
    Dim WS As Worksheet,src As Worksheet
 
    f = "من المدرسة"
    Set WS = Sheets("الصف الثانى ")
    Set src = Sheets("محولين الى المدرسة")
    
    Application.ScreenUpdating = False
    
    ' مسح المحتويات السابقة في الورقة الوجهة
    'src.Range("B10:U" & src.Rows.Count).ClearContents  <<===== غير مفعل 
   
    lastRow = WS.Range("V" & WS.Rows.Count).End(xlUp).Row
    lr = src.Range("b" & src.Rows.Count).End(xlUp).Row

    For Cnt = lastRow To 10 Step -1
        If UCase(WS.Range("V" & Cnt).Value) Like UCase(f) Then
            n = n + 1 
            src.Range("B" & n + lr & ":U" & n + lr).Value = WS.Range("B" & Cnt & ":U" & Cnt).Value
            ' حذف الصف من الورقة المصدر بعد نسخه
            WS.Rows(Cnt).Delete
        End If
    Next Cnt
    
    Application.ScreenUpdating = True
End Sub

 

تم تعديل أغسطس 20 بواسطه محمد هشام.