Dim r As Range, c As Range, dest As Range Dim j As Long, r1 As Range Worksheets("sheet1").Activate Set r = Range(Range("A3"), Range("A3").End(xlDown)) For Each c In r j = c.Value c.EntireRow.Copy With Worksheets("sheet2") Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) Set r1 = Range(dest, dest.Offset(j - 1, 0)) r1.PasteSpecial End With Next c application.cutcopymode=false End Sub
Sub test() Dim r As Range, c As Range, dest As Range Dim j As Long, r1 As Range Worksheets("sheet1").Activate Set r = Range(Range("A3"), Range("A3").End(xlDown)) For Each c In r j = c.Value c.EntireRow.Copy With Worksheets("sheet2") Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) msgbox dest.address Set r1 = Range(dest, dest.Offset(j - 1, 0)) msgbox r1.address r1.PasteSpecial End With Next c application.cutcopymode=false End Sub
DON'T MISS
Thank you for yor help