Loop to copy each row and paste to a new tab 4 times

[zach9208]

I am trying to write a macro to copy each line from columns A to E and paste each row 3 times on another tab. I need this macro to loop through until it hits a blank row. Here is code that I recorded, but I do not know how to make this into a loop. I also have a piece of code that grabs F to I and then transposes this piece when pasted to the UIL tab.

Sub MakeDuplicatesofEachRow()

    Sheets("Data").Select
    Range("A2:E2").Select
    Selection.Copy
    
    Sheets("UIL").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Sheets("Data").Select
    Range("F2:I2").Select
    Application.CutCopyMode = False
    Selection.Copy
    
    Sheets("UIL").Select
    Range("F2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
End Sub

Lastly, it would be great if I could build in this code to copy the range g2:G5 and paste this in the UIL tab until I hit a blank row based on column A.

Sub Macro5()

    Sheets("UIL").Select
    Range("G2:G5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G6").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
End Sub

 

[Fluff]

Hi
This does the first part.

Sub CopyRngx4()
' Zach9208

    Dim DSht As Worksheet
    Dim Rng As Range
    
Application.ScreenUpdating = False

    Set DSht = Sheets("UIL")
    
    With Sheets("Data")
        For Each Rng In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Rng.Resize(, 5).Copy DSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4, 5)
            Rng.Offset(, 5).Resize(, 4).Copy
            DSht.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
        Next Rng
    End With

Application.CutCopyMode = False

End Sub

As for the second part , what do you have in G2:G5?

 

[zach9208]

The second part G2:G5 is a static range that will always be on the UIL tab. It is 4 rows of the classifcation of the date. Since the lines from the Data tab are always in this order, I want a macro to drag these four classification in the same order until it hits the end of the data on the UIL tab.

Hi
This does the first part.

Sub CopyRngx4()
' Zach9208

    Dim DSht As Worksheet
    Dim Rng As Range
    
Application.ScreenUpdating = False

    Set DSht = Sheets("UIL")
    
    With Sheets("Data")
        For Each Rng In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Rng.Resize(, 5).Copy DSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4, 5)
            Rng.Offset(, 5).Resize(, 4).Copy
            DSht.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
        Next Rng
    End With

Application.CutCopyMode = False

End Sub

As for the second part , what do you have in G2:G5?

 

[zach9208]

I should have included this in my first reply. Your macro code worked marvelously!

Hi
This does the first part.

Sub CopyRngx4()
' Zach9208

    Dim DSht As Worksheet
    Dim Rng As Range
    
Application.ScreenUpdating = False

    Set DSht = Sheets("UIL")
    
    With Sheets("Data")
        For Each Rng In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Rng.Resize(, 5).Copy DSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4, 5)
            Rng.Offset(, 5).Resize(, 4).Copy
            DSht.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
        Next Rng
    End With

Application.CutCopyMode = False

End Sub

 

[Fluff]

Try

Sub CopyRngx4()
' Zach9208

    Dim DSht As Worksheet
    Dim Rng As Range
    Dim Fll As Long
    
Application.ScreenUpdating = False

    Set DSht = Sheets("UIL")
    
    With Sheets("Data")
        For Each Rng In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Rng.Resize(, 5).Copy DSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4, 5)
            Rng.Offset(, 5).Resize(, 4).Copy
            DSht.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
        Next Rng
    End With
    With DSht
        Fll = .Range("A" & Rows.Count).End(xlUp).Row - 5
        .Range("G2:G5").Copy .Range("G6").Resize(Fll)
    End With

Application.CutCopyMode = False

End Sub

 

[zach9208]

Worked exactly the way I needed. Thank you so much, Fluff!!!!

Try

Sub CopyRngx4()
' Zach9208

    Dim DSht As Worksheet
    Dim Rng As Range
    Dim Fll As Long
    
Application.ScreenUpdating = False

    Set DSht = Sheets("UIL")
    
    With Sheets("Data")
        For Each Rng In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            Rng.Resize(, 5).Copy DSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(4, 5)
            Rng.Offset(, 5).Resize(, 4).Copy
            DSht.Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=True
        Next Rng
    End With
    With DSht
        Fll = .Range("A" & Rows.Count).End(xlUp).Row - 5
        .Range("G2:G5").Copy .Range("G6").Resize(Fll)
    End With

Application.CutCopyMode = False

End Sub

 

[Fluff]

Glad to help & thanks for the feedback