اذهب الي المحتوي
أوفيسنا

كود استدعاء البيانات حسب مامطلوب في ترحيل الناجحون او الراسبون او المكملون وحسب الصف

عامر ياسر

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

 مشاركة

الردود الموصى بها

سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو)

الكود 

Option Explicit

Sub filter_ME()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("a1")
    .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("b1")
    .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("c1")
    .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("d1")
    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 1 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1
    m = m + 1
    If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
 Next
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

الملف مرفق

 

الترحيل salim.xlsm

  • Like 2
رابط هذا التعليق
شارك
عامر ياسر

عامر ياسر

قام بنشر
  • الكاتب
قام بنشر
5 دقائق مضت, سليم حاصبيا said:

جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو)

الكود 


Option Explicit

Sub filter_ME()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    .Columns(18).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("a1")
    .Columns(2).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("b1")
    .Columns(3).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("c1")
    .Columns(5).SpecialCells(xlCellTypeVisible).Offset(1).Copy _
    Destination:=Sheets("Sapace").Range("d1")
    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 1 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k: T_sh.Range("f" & m) = k + 1
    m = m + 1
    If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
 Next
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

الملف مرفق

 

الترحيل salim.xlsm

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

  • Like 2
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

يجب كتابة هذه الكلمات (ناجح / راسب/مكمل) في الجدول الاساسي بالضبط كما هي في القائمة المنسدلة دون مسافات ناقصة او زائدة

ربما هناك بعض الاخطاء في كتابة بعضها

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

تم معالحة الامر

الكود الجديد 

Option Explicit
Sub filter_ME_Please()
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim My_arr(): ReDim My_arr(1 To 4)
My_arr(1) = 18: My_arr(2) = 2
My_arr(3) = 3: My_arr(4) = 5
Dim lr%, k%, m%: m = 5
Dim S_sh As Worksheet: Set S_sh = Sheets("الدرجات")
Dim T_sh As Worksheet: Set T_sh = Sheets("salim")
Dim My_Table As Range: Set My_Table = _
 S_sh.Range("A4").CurrentRegion
 T_sh.Range("a4").CurrentRegion.Offset(3).ClearContents
  With My_Table
    .AutoFilter
    .AutoFilter Field:=16, Criteria1:=T_sh.Range("d3")
    .AutoFilter Field:=17, Criteria1:=T_sh.Range("d2")
    Sheets("Sapace").Cells.Clear
    For k = 1 To 4
    .Columns(My_arr(k)).SpecialCells(xlCellTypeVisible).Copy _
    Destination:=Sheets("Sapace").Range("a1").Offset(, k - 1)
    Next

    .AutoFilter
End With
'======================
lr = Sheets("Sapace").Cells(Rows.Count, 1).End(3).Row
 For k = 2 To lr Step 2
    T_sh.Range("b" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k).Resize(, 4).Value
    T_sh.Range("g" & m).Resize(, 4).Value = _
    Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value
    T_sh.Range("a" & m) = k - 1: T_sh.Range("f" & m) = k
    m = m + 1
    
 Next
 If IsEmpty(T_sh.Range("G" & m - 1)) Then T_sh.Range("f" & m - 1) = vbNullString
     With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
     End With
Erase My_arr
End Sub

الملف مرفق

 

 

الترحيل salim_modifier .xlsm

  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر
1 دقيقه مضت, عامر ياسر said:

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

ط§ظ„طھط±ط­ظٹظ„ salim.xlsm

تم ارسال الملف والكود الجديد  في المشاركة ما قبل هذه تحت اسم           الترحيل salim_modifier.xlsm 

  • Like 1
رابط هذا التعليق
شارك
عامر ياسر

عامر ياسر

قام بنشر
  • الكاتب
قام بنشر

فقط مشكلة بسيطة وهي فقط حينما اختار المكمل والراسب التسلسل 1 والتسلسل 2 يكرر ... جزاك الله خيرا قمت بتقليل البيانات في الجدول الأساسي والمثال صف الاول قمت بتلوينه حينما اختار المكمل للصف الاول يكرر فقط التسلسل الاول والثاني بنفس الاسم ويعطيني زيادة واحدة  حول عدد التلاميذ  المكمل الصف الاول واحد يكرره لي مرتين كما في الملف المرفق

2„ salim_modifier.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

لاحظت انا هذا الشيء و قد ورد خظأ بسيط تم تصليحة

اعد تحميل الملف مرة احرى

الحطأ في هذا السطر (رقم 11 من الاسفل) 

Sheets("Sapace").Range("a" & k ).Resize(, 4).Value

و يجب ان يكون هكذا 

Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value

 

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept