hasha737 قام بنشر مايو 12, 2019 مشاركة قام بنشر مايو 12, 2019 الرجاء المساعدة من عباقرة الاكسل في الموقع الرائع مرفق لكم النموذج للعمل نموذج العمل على القالب.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 12, 2019 مشاركة قام بنشر مايو 12, 2019 البيانات كثيرة جداً مما يجعل عملية متابعة الكود الذي سيتم وضعه صعبة لذلك قم بتحميل نموذح صغير عن الملف (3 أو 4 اسماء ) عن كل مادة لوضع كود مناسب و من ثم يتم تعميم هذا الكود على الملف الأصلي رابط هذا التعليق شارك More sharing options...
hasha737 قام بنشر مايو 13, 2019 الكاتب مشاركة قام بنشر مايو 13, 2019 تسلم ياخي سليم هذا الملف الجديد (3 اسماء فقط وشكر لتفاعلك نموذج العمل على القالب2.xlsx رابط هذا التعليق شارك More sharing options...
وجيه شرف الدين قام بنشر مايو 13, 2019 مشاركة قام بنشر مايو 13, 2019 اتفضل الملف لعله يفى بالغرض نموذج العمل على القالب.xlsx 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر مايو 13, 2019 مشاركة قام بنشر مايو 13, 2019 جرب هذا الكود Option Explicit Sub give_Data() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Nous As Worksheet: Set Nous = Sheets("شيت نص السنة") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Nous_ro%: Nous_ro = Nous.Cells(Rows.Count, 1).End(3).Row Kaleb.Range("a2:t5000").ClearContents Dim Rg_Nous As Range: Set Rg_Nous = Nous.Range("a1:G" & Nous_ro) Dim Nous_r%: Nous_r% = Rg_Nous.Rows.Count Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Nous If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Nous.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Nous.Offset(1, 0).Resize(Nous_r% - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Kaleb.Cells(m, 1).Resize(Y, 6).Value = _ Filter_range.Areas(t).Cells(1, 1).Resize(Y, 6).Value Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With give_Data1 End Sub Rem============================================= Sub give_Data1() Dim k As Byte, x%, Xera%, t%, Y% Dim my_cel, m%: m = 2 Dim col% Dim Filter_range As Range Dim Shahr As Worksheet: Set Shahr = Sheets("شيت الشهري") Dim Kaleb As Worksheet: Set Kaleb = Sheets("قالب رفع الدرجات") Dim Shahr_ro%: Shahr_ro = Shahr.Cells(Rows.Count, 1).End(3).Row Dim Rg_Shahr As Range: Set Rg_Shahr = Shahr.Range("a1:G" & Shahr_ro) Dim mY_arr(): mY_arr = Array(1, 2, 3, 4, 5, 7) With Shahr If .FilterMode Then .ShowAllData .AutoFilterMode = False End If For k = 0 To 5 Rg_Shahr.AutoFilter 3, mY_arr(k) Set Filter_range = Rg_Shahr.Offset(1, 0).Resize(Shahr_ro - 1).SpecialCells(xlCellTypeVisible) Xera = Filter_range.Areas.Count For t = 1 To Xera Y = Filter_range.Areas(t).Rows.Count Select Case mY_arr(k) Case 1: col = 20 Case 2: col = 8 Case 3: col = 10 Case 4: col = 14 Case 5: col = 16 Case 7: col = 12 End Select Kaleb.Cells(m, col - 1).Resize(Y, 1).Value = _ Filter_range.Areas(t).Cells(1, 7).Resize(Y, 1).Value m = m + Y Next t Next k .AutoFilterMode = False End With End Sub الملف simple_data.xlsm 2 رابط هذا التعليق شارك More sharing options...
وجيه شرف الدين قام بنشر مايو 13, 2019 مشاركة قام بنشر مايو 13, 2019 دائما سباق الى الخير استاذ سليم 2 رابط هذا التعليق شارك More sharing options...
hasha737 قام بنشر مايو 13, 2019 الكاتب مشاركة قام بنشر مايو 13, 2019 أخي سليم أنا اريد برنامج حسب الطلب هل ممكن رقمك نتواصل رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان