كود ترحيل

[aafaq1000@yahoo.com]

مطلوب كود ترحيل للدور الثاني والملف موضح به المطلوب

شيت درجات.rar

[ابراهيم الحداد]

السلام عليكم ورحمة الله

استخدم الكود الآتى

Sub Result2()
Dim ws As Worksheet, sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Set ws = Sheets("تسجيل الدرجات")
Set sh = Sheets("دور ثاني")
sh.Range("A10:U" & sh.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents
Arr = ws.Range("B9:CS" & ws.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) = "راسب" Then
p = p + 2
For j = 1 To 18
Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 15, 16, 17, 18, 19, 20)) = Arr(i, Choose(j, 1, 2, 3, 5, 6, 7, 8, 9, 10, 19, 28, 37, 48, 59, 68, 79, 82, 85, 87, 96))
Cells(p + 8, 1) = p / 2
Next
End If
Next
sh.Range("B9").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub

 

[aafaq1000@yahoo.com]

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

اولا يعطي الاسم مكان النتيجة

ثانيا اريد الصف الفارغ يكون صف 10

ثالثا لا اريد مسح بيانات الصفوف 10 و 12 و 14 ... الخ

رابعا الرقم السري يكون فارغ

مرفق الملف بعد وضع الكود

 

شيت درجات.rar

تم تعديل يوليو 21, 2017 بواسطه aafaq1000@yahoo.com

[ابراهيم الحداد]

السلام عليكم ورحمة الله

يوجد خطأ فى تصميم الملف لديك حيث تم تكرار عمود النتيجة

لذا قمت بازالة احدهما

اليك الملف بعد التعديل

 

 

شيت درجات.rar

[aafaq1000@yahoo.com]

اسف لتعب حضرتك ولكن في خطأ في المجموع الكلي و مادة الدين 

ارغب في عدم مسح الصفوف 10 و12 و14 .

... الخ لان سيتم تسجيل الدرجات بها

مسح الخلايا السري

 

[ابراهيم الحداد]

السلام عليكم ورحمة الله

اليك الكود بعد التعديل

Sub ترحيل()
'
' ترحيل ماكرو
'
Dim ws As Worksheet, sh As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Set ws = Sheets("تسجيل الدرجات")
Set sh = Sheets("دور ثاني")
sh.Range("A10:U" & sh.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents
Arr = ws.Range("B9:CS" & ws.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) = "راسب" Then
p = p + 2
For j = 1 To 18
 Temp(p, Choose(j, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 15, 16, 17, 18, 19, 20)) _
= Arr(i, Choose(j, 1, 2, 3, 5, 6, 7, 8, 9, 10, 19, 28, 37, 48, 59, 68, 79, 87, 96))
sh.Cells(p + 9, 1) = p / 2
Next
End If
Next
sh.Range("B10").Resize(p, UBound(Temp, 2)).Value = Temp
End Sub

 

[aafaq1000@yahoo.com]

الف شكر على الكود الرائع وتعبك معايا ولكن الطلب الاخير

اثناء الترحيل لايتم مسح الصفوف 10 و 12 و 14 ... الخ وذلك لان تلك الصفوف يتم تسجيل درجات الدور الثاني بها

 

[ناصر سعيد]

هذا الكود من الكنوز الخاصه برجال التربيه والتعليم بارك الله لك استاذ زيزو ويحفظك

وشكرا للسائل جزاه الله خيرا

=====

ارجو ان تشرح اسطره لكي يكون سهلا للجميع كي يتم توافقه مع ملفاتهم

وجزاك الله خيرا

[ناصر سعيد]

السؤال هنا لاخي السائل بعد نقلك للدرجات الخاصه بطلاب الدور التاني

كيف ستعرف الدرجه المقصر فيها الطالب حتى تكتب فوقها ؟

برجاء من المحترم زيزو ان يضيف جزئيه بعدد طلاب الدور التاني فقط  يعني يتم التسطير للخلايا بالعدد