Copy the row multiple times while translating the columns

[Anamik]

(Sorry for cross posting but I did not get a satisfactory respons ein
excel.mis)

Hi,

I want to copy each row in the file 3 times one after another. The second
copy should be translated one column to the left and the third copy two
columns to the left. For example, suppose I copy the rows
a b c
d e f
They should look like
a b c
a b c
a b c
d e f
d e f
d e f
Thank you very much in advance.
Anamik.

 

[Tom Ogilvy]

Sub Copy3Times()
Dim sh As Worksheet, sh1 As Worksheet
Dim col As Long, cell As Range
Dim rw As Long, rng As Range
Set sh = ActiveSheet
Set sh1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
sh.Activate
col = ActiveSheet.Cells(1, "IV").End(xlToLeft).Column
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rw = 1
For Each cell In rng
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw, 3)
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw + 1, 2)
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw + 2, 1)
rw = rw + 3
Next cell
End Sub

 

[Anamik]

Sub Copy3Times()

Dim sh As Worksheet, sh1 As Worksheet
Dim col As Long, cell As Range
Dim rw As Long, rng As Range
Set sh = ActiveSheet
Set sh1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
sh.Activate
col = ActiveSheet.Cells(1, "IV").End(xlToLeft).Column
Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
rw = 1
For Each cell In rng
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw, 3)
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw + 1, 2)
cell.Resize(1, col).Copy Destination:=sh1.Cells(rw + 2, 1)
rw = rw + 3
Next cell
End Sub

Tom thank you very much and sorry for getting back after so long. The
function you have given works. The only problem is it keeps on creating new
sheets without stopping. I inserted break point at the beginning and could
stop it manually. So, for me it works.
Thank you very much.
Anamik.