عامر ياسر قام بنشر يونيو 27, 2018 مشاركة قام بنشر يونيو 27, 2018 السلام عليكم ورحمة الله وبركاته الشرح موجود داخل ملف الاكسيل الترحيل.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 27, 2018 مشاركة قام بنشر يونيو 27, 2018 جرب هذا الملف (تم تعيير بعض الاشياء لحسن عمل الماكرو) الكود 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 2 رابط هذا التعليق شارك More sharing options...
عامر ياسر قام بنشر يونيو 27, 2018 الكاتب مشاركة قام بنشر يونيو 27, 2018 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 انت مبدع بمعنى الكلمة إجابة وعمل غاية في الروعة شكرا من القلب لك استاذي سليم حاصبيا ... لقد اختصرت لي الطريق في عملي الإداري انت غي غاية الكرم واعظم ما تقدمه هو العلم (إن الله يحب إذا عمل أحدكم عملاً أن يتقنه ) اتقنت في الإجابة وهذا ما اريده بالضبط شكرا لك 2 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 28, 2018 مشاركة قام بنشر يونيو 28, 2018 يجب كتابة هذه الكلمات (ناجح / راسب/مكمل) في الجدول الاساسي بالضبط كما هي في القائمة المنسدلة دون مسافات ناقصة او زائدة ربما هناك بعض الاخطاء في كتابة بعضها 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 28, 2018 مشاركة قام بنشر يونيو 28, 2018 تم معالحة الامر الكود الجديد 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 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 28, 2018 مشاركة قام بنشر يونيو 28, 2018 1 دقيقه مضت, عامر ياسر said: حاولت ولم اصل لنتيجة هل يمكن معالجة المشكلة داخل الملف عندك وارساله لي مع تقديري واحترامي ط§ظ„طھط±طظٹظ„ salim.xlsm تم ارسال الملف والكود الجديد في المشاركة ما قبل هذه تحت اسم الترحيل salim_modifier.xlsm 1 رابط هذا التعليق شارك More sharing options...
عامر ياسر قام بنشر يونيو 28, 2018 الكاتب مشاركة قام بنشر يونيو 28, 2018 فقط مشكلة بسيطة وهي فقط حينما اختار المكمل والراسب التسلسل 1 والتسلسل 2 يكرر ... جزاك الله خيرا قمت بتقليل البيانات في الجدول الأساسي والمثال صف الاول قمت بتلوينه حينما اختار المكمل للصف الاول يكرر فقط التسلسل الاول والثاني بنفس الاسم ويعطيني زيادة واحدة حول عدد التلاميذ المكمل الصف الاول واحد يكرره لي مرتين كما في الملف المرفق 2„ salim_modifier.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 28, 2018 مشاركة قام بنشر يونيو 28, 2018 لاحظت انا هذا الشيء و قد ورد خظأ بسيط تم تصليحة اعد تحميل الملف مرة احرى الحطأ في هذا السطر (رقم 11 من الاسفل) Sheets("Sapace").Range("a" & k ).Resize(, 4).Value و يجب ان يكون هكذا Sheets("Sapace").Range("a" & k + 1).Resize(, 4).Value 1 رابط هذا التعليق شارك More sharing options...
عامر ياسر قام بنشر يونيو 28, 2018 الكاتب مشاركة قام بنشر يونيو 28, 2018 تمام استاذنا الكريم سليم حاصبيا ابدعت وارجو المعذرة قد اتعبتك كثيرا بأسئلتي ادعوا من الله عز وجل ان يوفقك ويزيد من علمك 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان