نجوم المشاركات

تفضل أخى Sub ragab() Dim cl As Range Dim arr() As Variant LR = [A1000].End(xlUp).Row T = 2: x = 2 '==================================== On Error Resume Next For Each cl In Range("A1:A" & LR) If IsDate(cl) Then Cells(1, T) = cl: T = T + 1 End If Next '==================================== For Each cl In Range("A2:A" & LR) If Not IsDate(cl) Then i = i + 1 ReDim Preserve arr(i) arr(i - 1) = cl Else Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr) x = x + 1: Erase arr: i = 0 End If Next Cells(2, x).Resize(i) = Application.WorksheetFunction.Transpose(arr) End Sub نسخ متعدد.rar

هل نجيب نحن ام ننتظر الاجابة من طرفكم ؟!