Como repetir varias veces un procedimiento de insertar filas con una macro

Buena tarde

Necesito insertar 3 filas cada 3 filas y en las filas que inserte copiar los 3 datos que hay en la columna b, necesito repetir varias veces este procedimiento hasta que no hayan mas datos en las columnas.

Sub Macro1()
'
' Macro1 Macro
'
'
Rows("4:6").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1:B3").Select
Selection.Copy
Application.CutCopyMode = False
Selection.Cut
Range("A4").Select
ActiveSheet.Paste
Rows("10:12").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B7:B9").Select
Selection.Cut
Range("A10").Select
ActiveSheet.Paste
Rows("16:18").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B13:B15").Select
Selection.Cut
Range("A16").Select
ActiveSheet.Paste
Rows("22:24").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B19:B21").Select
Selection.Cut
Range("A22").Select
ActiveSheet.Paste
Rows("28:30").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B25:B27").Select
Selection.Cut
Range("A28").Select
ActiveSheet.Paste
End Sub

Muchas gracias por la ayuda