أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

السلام عليكم ورحمة الله وبركاته معي كود ترحيل بالملف للعشره الأوائل ----- لكن نصفه شغال والأخر غير شغال لا ادري اين الخل ..



20-08-2020 07:52 مساء
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 

السلام عليكم ورحمة الله وبركاته
معي كود ترحيل بالملف للعشره الأوائل
----- لكن نصفه شغال والأخر غير شغال لا ادري اين الخلل؟؟؟
------كما انني اريد عشرة طلاب فقط . . لكنه يزيد عن ذلك... ولا ادري ايضا ما الخلل..
رجاءا المساعده
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  ضبط خلل بالكود ترحيل.rar   تحميل rar مرات التحميل :(3)
الحجم :(159.538) KB


21-08-2020 12:24 صباحا
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 237
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 34
قوة السمعة : 2349
عدد الإجابات: 31
 offline 
look/images/icons/i1.gif ضبط خلل بالكود ترحيل
السلام عليكم ورحمة الله
تم تعديل الكود
Sub الاوائل()
Dim ws As Worksheet, Sh As Worksheet
Dim X As Integer, R As Long, i As Integer, y As Integer
Dim LS As Long, z As Integer
Dim st As String

Set ws = Sheets("DATA")
Set Sh = Sheets("TARHEEL")
Sh.Range("F14:M27").ClearContents
m = 13
lr = ws.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For R = 5 To lr Step 4
If IsNumeric(ws.Range("BE" & R)) And ws.Range("BE" & R) > 1 Then
X = WorksheetFunction.Rank(ws.Range("BE" & R), ws.Range("BE5:BE" & lr))

If X <= 10 Then
m = m + 1
Sh.Cells(m, 6) = (m - 13)
Sh.Cells(m, 7) = ws.Cells(R, 2)
Sh.Cells(m, 8) = ws.Cells(R, 3)
Sh.Cells(m, 9) = ws.Cells(R, 57)
Sh.Cells(m, 11) = ws.Cells(R + 3, 57)
Sh.Cells(m, 13) = ws.Cells(R, 78)
Sh.Cells(m, 10) = Sh.Cells(m, 9) / 950
End If
End If
Next
LS = Sh.Range("I" & Rows.Count).End(xlUp).Row
For i = 14 To LS
'On Error Resume Next
y = WorksheetFunction.Rank(Sh.Range("I" & i), Sh.Range("I14:I" & LS))
z = WorksheetFunction.CountIf(Sh.Range("L14:I" & i), Sh.Range("L" & i))

If y < 1 Or y > 10 Then Exit Sub
st = Choose(y, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _
"السادس", "السابع", "الثامن", "التاسع", "العاشر")
If z > 1 Then
Sh.Range("L" & i) = st & " " & "مكرر"
Else
Sh.Range("L" & i) = st
End If
Next
'''''  للفلتره
    Range("G13:M13").Select
    Selection.AutoFilter
        Sh.AutoFilter.Sort.SortFields.Clear
        Sh.AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("I13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With Sh.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
     End With
     Selection.AutoFilter

   'عمل النسبة المئوية
  Range("J14:J23") = "= I14/950"
    Range("H14").Select
  
  
Application.ScreenUpdating = True
End Sub

21-08-2020 12:53 صباحا
مشاهدة مشاركة منفردة [2]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ضبط خلل بالكود ترحيل
جزاك الله خيرا استاذ ابراهيم على هذا التعديل الرائع
Sub الاوائل()
Dim ws As Worksheet, Sh As Worksheet
Dim X As Integer, R As Long, i As Integer, y As Integer
Dim LS As Long, z As Integer
Dim st As String

Set ws = Sheets("DATA")
Set Sh = Sheets("TARHEEL")
Sh.Range("F14:M27").ClearContents
m = 13
lr = ws.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For R = 5 To lr Step 4
If IsNumeric(ws.Range("BE" & R)) And ws.Range("BE" & R) > 1 Then
X = WorksheetFunction.Rank(ws.Range("BE" & R), ws.Range("BE5:BE" & lr))

If X <= 10 Then
m = m + 1
Sh.Cells(m, 6) = (m - 13)
Sh.Cells(m, 7) = ws.Cells(R, 2)
Sh.Cells(m, 8) = ws.Cells(R, 3)
Sh.Cells(m, 9) = ws.Cells(R, 57)
Sh.Cells(m, 11) = ws.Cells(R + 3, 57)
Sh.Cells(m, 13) = ws.Cells(R, 78)
Sh.Cells(m, 10) = Sh.Cells(m, 9) / 950
End If
End If
Next
LS = Sh.Range("I" & Rows.Count).End(xlUp).Row
For i = 14 To LS
'On Error Resume Next
y = WorksheetFunction.Rank(Sh.Range("I" & i), Sh.Range("I14:I" & LS))
z = WorksheetFunction.CountIf(Sh.Range("I14:I" & i), Sh.Range("I" & i))

If y < 1 Or y > 10 Then Exit Sub
st = Choose(y, "الاول", "الثانى", "الثالث", "الرابع", "الخامس", _
"السادس", "السابع", "الثامن", "التاسع", "العاشر")
If z > 1 Then
Sh.Range("L" & i) = st & " " & "مكرر"
Else
Sh.Range("L" & i) = st
End If
Next
'''''  للفلتره
    Range("G13:M13").Select
    Selection.AutoFilter
        Sh.AutoFilter.Sort.SortFields.Clear
        Sh.AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("I13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With Sh.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
     End With
     Selection.AutoFilter

   'عمل النسبة المئوية
  'Range("J14:J23") = "= I14/950"
    'Range("H14").Select
  
  
Application.ScreenUpdating = True
End Sub




الكلمات الدلالية
ترحيل ، بالكود ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:44 مساء