بعد اذن الأستاذ الفاضل / عبد الله المجرب
ولاثراء الموضوع
هذا كود بفكرة أخرى
Sub ragab()
Dim arr() As String
Set sh = Sheets("ورقة2")
sh.UsedRange.ClearContents
x = 2: Z = [E4] + 1
'================================
For R = 4 To 6
i = Cells(R, 5) + 1
ReDim arr(1 To i)
arr(1) = Cells(R, 4)
xx = 2
For T = x To Z
arr(xx) = Cells(T, 1)
xx = xx + 1
Next
LR = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh.Range("A" & LR).Resize(i) = Application.WorksheetFunction.Transpose(arr)
x = x + Cells(R, 5)
Z = Z + Cells(R + 1, 5)
Erase arr
Next
End Sub
1111الترحيل بشرط قيمة متغيرة.rar