الترحيل بالفلترة - ترويسة و تذييل بالكود

[محمد فاروق محمود]

ارجو من حضراتكم مساعدتى فى تعديل على عمل مميز لاحد السادة المحترفين واريد تعديل فى ترحيل

الترحيل بالفلترة - ترويسة و تذييل بالكود.rar

[أبو محمد أشرف]

أرجو التوضيح أكثر أخي

تقصد آخر عمود للترحيل  المجموع وليس آخر صف

وأرجو مزيد توضيح بالنسبة للعبارة

للمجمع بحيث يكون صفوف 25-50-75

[محمد فاروق محمود]

شكرا يا اخ اشرف على الاهتمام برجاء مساعدتى على اساس ان الترحيل يكون ثابت على اساس 25 صف وكونت اود ان يخصص cد اخر صف فى كل مرة ترحيل لعمل مجموع للعمو

وشكرا

شكرا على المرور الكريم برجاء مساعدتى عندما يتم تحدي الثابت على اثاث 25 صف للترحيل كنت اود ان يجعل اخر صف للمجموع ويكون المجموع للعمود سى وشكرا

الحمد لله توصلت لخانة المجموع ويتبقى ترحيل راسب فى صفحة ناجح بدا من صف 177 والغاء صفحة راسب

توضيح اكثر للمطلوب برجاء المساعدة

الترحيل بالفلترة - ترويسة و تذييل بالكود.rar

[احمد عبد الناصر]

السلام عليكم

 

جرب هذا الكود

 

Sub dahmour()
Application.ScreenUpdating = False

With Sheets(1)
.Select
.AutoFilterMode = False
 lastrow = Range("a" & Rows.Count).End(xlUp).Row
.Range("A1:D" & lastrow).AutoFilter
.Range("A1:D" & lastrow).AutoFilter Field:=4, Criteria1:="ناجح"
.Range("a2:d" & lastrow).Copy Sheets(2).Range("a1")
.AutoFilterMode = False
End With
'''''''''''''''''''''''''''''''
With Sheets(2)
.Select
x = 1
Do
 Sheets(1).Range("a1:d1").Copy
 .Range("a" & x & ":d" & x).Insert Shift:=xlDown
  x = x + 21
  Rows(x & ":" & x + 3).Insert Shift:=xlDown
  Cells(x + 3, 3) = "=SUM(R[-24]C:R[-1]C)"
  x = x + 4
  If IsEmpty(Cells(x, 2)) Then Exit Do
Loop
End With
'88888888888888888888888888888888888888888888888888888888
With Sheets(1)
.Select
.AutoFilterMode = False
 lastrow = Range("a" & Rows.Count).End(xlUp).Row
.Range("A1:D" & lastrow).AutoFilter
.Range("A1:D" & lastrow).AutoFilter Field:=4, Criteria1:="راسب"
.Range("a2:d" & lastrow).Copy Sheets(2).Range("a" & x)
.AutoFilterMode = False
End With
'''''''''''''''''''''''''''''''
With Sheets(2)
.Select
r = x
Do
 Sheets(1).Range("a1:d1").Copy
 .Range("a" & r & ":d" & r).Insert Shift:=xlDown
  r = r + 21
  Rows(r & ":" & r + 3).Insert Shift:=xlDown
  Cells(r + 3, 3) = "=SUM(R[-24]C:R[-1]C)"
  r = r + 4
  If IsEmpty(Cells(r, 2)) Then Exit Do
Loop

End With

Application.CutCopyMode = False
'''''''''''''''''''''''''''''''

Application.ScreenUpdating = True
End Sub

 

 

تحياتي

[محمد فاروق محمود]

حل احترافى جزاك الله كل الخير