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

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


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





ترحيل ناجحين وراسبين بشروط

السلام عليكم ورحمة الله وبركاته معي ملف حاولت بتعديل الكود فيه لترحيل الناجحين والراسبين...لكن نظرا لوجود شروط لم استطع ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


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

السلام عليكم ورحمة الله وبركاته
معي ملف حاولت بتعديل الكود فيه لترحيل الناجحين والراسبين...لكن نظرا لوجود شروط لم استطع ...
هل  من مساعده؟؟؟
الناجح معياره( ناجـح - منقـول)
 
 
 
  ترحيل.rar   تحميل rar مرات التحميل :(16)
الحجم :(24.066) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
وعليكم السلام 
جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Const iRow As Long = 7, iCol As Long = 30
    Dim ws As Worksheet, wsNageh As Worksheet, wsRaseb As Worksheet, lr As Long, r As Long, n1 As Long, n2 As Long
    Application.ScreenUpdating = False
        With ThisWorkbook
            Set ws = .Worksheets("dataa")
            lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
            Set wsNageh = .Worksheets("nageh")
            wsNageh.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
            Set wsRaseb = .Worksheets("raseb")
            wsRaseb.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
        End With
        n1 = iRow: n2 = iRow
        For r = iRow To lr
            If InStr(ws.Cells(r, iCol).Value, "ناجــح") Or InStr(ws.Cells(r, iCol).Value, "منقـول") Then
                wsNageh.Range("A" & n1).Value = n1 - iRow + 1
                wsNageh.Range("B" & n1).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
                n1 = n1 + 1
            ElseIf InStr(ws.Cells(r, iCol).Value, "راسب") Or InStr(ws.Cells(r, iCol).Value, "غائب") Then
                wsRaseb.Range("A" & n2).Value = n2 - iRow + 1
                wsRaseb.Range("B" & n2).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
                n2 = n2 + 1
            End If
        Next r
    Application.ScreenUpdating = True
    MsgBox "Done", 64, "YasserKhalil Excel-Egy"
End Sub
عرض الإجابة




23-08-2020 07:49 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
وعليكم السلام 
جرب الكود التالي عله يفي بالغرض إن شاء الله
Sub Test()
    Const iRow As Long = 7, iCol As Long = 30
    Dim ws As Worksheet, wsNageh As Worksheet, wsRaseb As Worksheet, lr As Long, r As Long, n1 As Long, n2 As Long
    Application.ScreenUpdating = False
        With ThisWorkbook
            Set ws = .Worksheets("dataa")
            lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
            Set wsNageh = .Worksheets("nageh")
            wsNageh.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
            Set wsRaseb = .Worksheets("raseb")
            wsRaseb.Range("A" & iRow & ":AD" & Rows.Count).ClearContents
        End With
        n1 = iRow: n2 = iRow
        For r = iRow To lr
            If InStr(ws.Cells(r, iCol).Value, "ناجــح") Or InStr(ws.Cells(r, iCol).Value, "منقـول") Then
                wsNageh.Range("A" & n1).Value = n1 - iRow + 1
                wsNageh.Range("B" & n1).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
                n1 = n1 + 1
            ElseIf InStr(ws.Cells(r, iCol).Value, "راسب") Or InStr(ws.Cells(r, iCol).Value, "غائب") Then
                wsRaseb.Range("A" & n2).Value = n2 - iRow + 1
                wsRaseb.Range("B" & n2).Resize(1, iCol - 1).Value = ws.Range("B" & r).Resize(1, iCol - 1).Value
                n2 = n2 + 1
            End If
        Next r
    Application.ScreenUpdating = True
    MsgBox "Done", 64, "YasserKhalil Excel-Egy"
End Sub

23-08-2020 09:32 مساء
مشاهدة مشاركة منفردة [2]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
تسلم استاذ ياسر من كل سووووووووووووووء
جزاك الله كل خير
هل يمكن الترحيل دون التقديرات  اي الترحيل فقط ( الجلوس- الاسم - - النتيجه)
MjU4NDk1MQ3434Untitled
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
 
  ترحيل1111.rar   تحميل rar مرات التحميل :(2)
الحجم :(23.242) KB


23-08-2020 11:35 مساء
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
Try This Macro

Option Explicit


Sub Salim_filter()
  Dim D As Worksheet, N As Worksheet
  Dim R As Worksheet
  Dim lrAD, arr(), i%
  Dim RgAD As Range
  Dim all_range As Range
Application.ScreenUpdating = False
arr = Array(1, 2, 3, 30)
 Set D = Sheets("dataa"): Set N = Sheets("nageh")
 Set R = Sheets("raseb")
  N.Range("A6").CurrentRegion.Clear
  R.Range("A6").CurrentRegion.Clear
 lrAD = D.Cells(Rows.Count, "ad").End(3).Row
 Set RgAD = D.Range("AD6:AD" & lrAD)
 Set all_range = D.Range("A6:AD" & lrAD)
 RgAD.AutoFilter 1, Criteria1:="*درجة*", _
 Operator:=xlOr, Criteria2:="*ناجــح*"
For i = 0 To 3
  all_range.Columns(arr(i)).SpecialCells(xlCellTypeVisible).Copy
  N.Range("A6").Offset(, i).PasteSpecial
Next
'+++++++++++++++++++++++++++++++++++
 RgAD.AutoFilter 1, Criteria1:="*راسب*", _
   Operator:=xlOr, Criteria2:="*غائب*"
 For i = 0 To 3
   all_range.Columns(arr(i)).SpecialCells(xlCellTypeVisible).Copy
   R.Range("A6").Offset(, i).PasteSpecial
 Next
D.Select
If D.AutoFilterMode Then RgAD.AutoFilter
 Application.ScreenUpdating = True

End Sub


الملف مرفق
 
 
  Tarhi_Iman.xlsm   تحميل xlsm مرات التحميل :(17)
الحجم :(33.423) KB


24-08-2020 04:35 صباحا
مشاهدة مشاركة منفردة [4]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
جزاك الله خيرا استاذ سليم
لكن المنقولين بمواد  ايضا يعتبرو ناجحين ...لكن لم يتم نقلهم..
اشكر حضرتك على سعة صدرك الواسعه

24-08-2020 05:53 صباحا
مشاهدة مشاركة منفردة [5]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
كان من المفروض بالنسبة للمنقول او الغائب
 كتابة ناجح او  راسب  و لو بين قوسين 
عندها تتم التصفية على  Criteria واحدة  (او راسب او ناجح)
على كل حال قومي بالتعديل كما في الصورة
لا تكتبي كلمة منقول او ناجح او راسب بشكل مختلف
مثلا "منقول" او "مــنقول" او "نـــاجح" أو "را ســـب" بل كما هي بالضبط في الكود
دون مسافات زائدة او ناقصة



2Rgk9_Iman

 
 
 


24-08-2020 06:06 صباحا
مشاهدة مشاركة منفردة [6]
نصر الإيمان
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 446
الجنس : ذكر
تاريخ الميلاد : 29-12-1985
يتابعهم : 8
يتابعونه : 4
قوة السمعة : 885
 offline 
look/images/icons/i1.gif ترحيل ناجحين وراسبين بشروط
جزاك الله خيرا


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
ترحيل ، ناجحين ، وراسبين ، بشروط ،


 










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

الساعة الآن 10:18 صباحا