Snasui Excel Forum

Code: Select all

Sub test()
    Dim i As Integer, j As Integer
    Dim rAll As Range
    With Sheets("Sheet2")
    Set rAll = .Range("A2", .Range("A" & Rows.Count) _
        .End(xlUp))
    j = rAll.Rows.Count
    End With
     Sheets("Sheet3").Cells.Clear
     For i = 1 To j
         With Sheets("Sheet3")
             If .Range("B1") = "" Then
                 rAll.Copy .Range("B1")
                 .Range("A1").Resize(j) = i
             Else
                 rAll.Copy .Range("B" & Rows.Count) _
                    .End(xlUp).Offset(1, 0)
               .Range("A" & Rows.Count).End(xlUp) _
                    .Offset(1, 0).Resize(j) = i
             End If
         End With
     Next i
End Sub