VBA to copy rows within the same sheet

[shimon.amar]

Dear fellows,

My boss gave me an assignment that I can't find a way to do it by macro.

assume I have database with lines -

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Code Number[/TD]
[TD]Sub-code[/TD]
[TD]Date[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]1234[/TD]
[TD][/TD]
[TD]12.12.12[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]5678[/TD]
[TD][/TD]
[TD]12.12.13[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Joe[/TD]
[TD]9876[/TD]
[TD][/TD]
[TD]11.12.12[/TD]
[TD]430[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

What I basically need to do is to duplicate each row 3 times and put the duplicated rows beneath the original rows.
For column "Sub-code" need to put numbers for each copied line (1, 2, 3).
For column "Amount" need to divide by 3 for each copied line.

Basically the data after macro should be like

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Code Number[/TD]
[TD]Sub-code[/TD]
[TD]Date[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]1234[/TD]
[TD][/TD]
[TD]12.12.12[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]1234[/TD]
[TD]1[/TD]
[TD]12.12.12[/TD]
[TD]33.33[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]1234[/TD]
[TD]2[/TD]
[TD]12.12.12[/TD]
[TD]33.33[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]1234[/TD]
[TD]3[/TD]
[TD]12.12.12[/TD]
[TD]33.33[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]5678[/TD]
[TD][/TD]
[TD]12.12.13[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]5678[/TD]
[TD]1[/TD]
[TD]12.12.13[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]5678[/TD]
[TD]2[/TD]
[TD]12.12.13[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]Jack[/TD]
[TD]5678[/TD]
[TD]3[/TD]
[TD]12.12.13[/TD]
[TD]100[/TD]
[/TR]
</tbody>[/TABLE]

****** id="cke_pastebin" style="position: absolute; top: 382px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">[TABLE="width: 500"]
<tbody>[TR]
[TD]1234[/TD]
[/TR]
</tbody>[/TABLE]
</body>Thank in advance, very much appreciated

 

[Fluff]

How about

Sub CopyRows3x()
   Dim i As Long
   
   For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
      Rows(i + 1).Resize(3).Insert
      Rows(i).Resize(4).FillDown
      Range("C" & i + 1).Resize(3).Value = Application.Transpose(Array(1, 2, 3))
      Range("E" & i + 1).Resize(3).Value = Range("E" & i).Value / 3
   Next i
End Sub

 

[shimon.amar]

How about

Sub CopyRows3x()
   Dim i As Long
   
   For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
      Rows(i + 1).Resize(3).Insert
      Rows(i).Resize(4).FillDown
      Range("C" & i + 1).Resize(3).Value = Application.Transpose(Array(1, 2, 3))
      Range("E" & i + 1).Resize(3).Value = Range("E" & i).Value / 3
   Next i
End Sub

Works great!! thank you very much!!

 

[Fluff]

Glad to help & thanks for the feedback