Row Shift, Copy, Paste question?

[dubmartian]

Hi all, I have searched and found pieces of parts but I really need your help.
Here is my task.

1. I have (x) number of rows with various text in a single column
1.5 I would like to copy the text in each row.
2. I would like to take each row, insert x number of rows beneath that and paste that text in the empty rows
3. and do this for the total amount of rows that were initially populated with text.

(Initial Text) Row 1 xxxxxx
Row 2 yyyyyy
Row 3 zzzzzzz

(Number of new rows input = 4)

(New Text) Row 1 xxxxxx
Row 2 xxxxxx
Row 3 xxxxxx
Row 4 xxxxxx
Row 5 yyyyyy
Row 6 yyyyyy
Row 7 yyyyyy
Row 8 yyyyyy
Row 9 zzzzzz
Row 10 zzzzzz
Row 11 zzzzzz
Row 12 zzzzzz

The number of rows should be inserted based on input and I have seen this VBA but not the copy paste and loop field.

If someone can help me with this it will be a life saver and I am forever grateful. I have no real VBA experience which is why I am asking for help.

DBM Thanks everyone

 

[MARK858]

Possible slow method below, btw in your results you are inserting 3 rows not 4 (4 in total including the original row) which is what the code below does.

The code below is for column A (please in future don't put "in a single column", actually state the column as it can cause problems when coding).

Sub insertrw()
    Dim i As Long, x As String
    Application.ScreenUpdating = False
    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        x = Cells(i, "A").Value
        Cells(i, "A").Resize(3, 1).Insert (xlDown)
        Cells(i, "A").Resize(3, 1).Value = x
    Next
    Application.ScreenUpdating = True
End Sub

 

[dubmartian]

Mark Thank you, this was not slow at all and works as I needed it to.
Are you able to break down whats happening in the macro? I need to do one more thing which is to append an underscore and sequence of numbers to the end of the text in each row.
xxxx_01
xxxx_02
xxxx_03
xxxx_04
yyyy_01

Thanks again for all your help . life saver for sure!!

 

[MARK858]

Mark Thank you, this was not slow at all

Depends on the definition of slow...

Anyway some code below. It isn't a thing of beauty but it will do until someone posts something better.

Sub xxx()
    Dim x As Range, y As Long, z
    Dim i As Long, j As String
    Application.ScreenUpdating = False

    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        j = Cells(i, "A").Value
        Cells(i, "A").Resize(3, 1).Insert (xlDown)
        Cells(i, "A").Resize(3, 1).Value = j
    Next

    For Each x In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        If x.Row = 1 Then
            z = x.Value
            x.Value = x.Value & "_" & 1
        Else
            If z <> x Then
                z = x.Value
                x.Value = x.Value & "_" & 1
            Else
                y = Mid(x.Offset(-1), InStr(x.Offset(-1), "_") + 1)
                x = x.Value & "_" & y + 1
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[MARK858]

Sorry, including the leading zero's.

Sub xxx()
    Dim x As Range, y As Long, z
    Dim i As Long, j As String
    Application.ScreenUpdating = False
   
    For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
        j = Cells(i, "A").Value
        Cells(i, "A").Resize(3, 1).Insert (xlDown)
        Cells(i, "A").Resize(3, 1).Value = j
    Next

    For Each x In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        If x.Row = 1 Then
            z = x.Value
            x.Value = x.Value & "_" & Format(1, "00")
        Else
            If z <> x Then
                z = x.Value
                x.Value = x.Value & "_" & Format(1, "00")
            Else
                y = Mid(x.Offset(-1), InStr(x.Offset(-1), "_") + 1)
                x = x.Value & "_" & Format(y + 1, "00")
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[dubmartian]

Mark, thanks again for your help.

Looks like everything works up to this line where it returns a type mismatch 13 for this line:

y = Mid(x.Offset(-1), InStr(x.Offset(-1), "_") + 1)


The output still created each additional row and it appends the _01 to Colum A row 1 only

 

[MARK858]

The only time I get a type mismatch is if there are blank cells. Are there?

 

[My Aswer Is This]

Try this:

Sub Fill_Me_Down_New()
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
    For i = Lastrow To 1 Step -1
        Cells(i, 1).Resize(4).FillDown
            If i > 1 Then Cells(i, 1).Resize(3).Insert xlDown
    Next
    Lastrow = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
    For b = 1 To Lastrow
        If x > 4 Then x = 1
        Cells(b, 1).Value = Cells(b, 1).Value & "_0" & x
        x = x + 1
    Next
    
Application.ScreenUpdating = True
End Sub

OK

 

[dubmartian]

The only time I get a type mismatch is if there are blank cells. Are there?

I had about 90 lines of text but no empty cells or rows between.

 

[dubmartian]

Try this:

Sub Fill_Me_Down_New()
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
    For i = Lastrow To 1 Step -1
        Cells(i, 1).Resize(4).FillDown
            If i > 1 Then Cells(i, 1).Resize(3).Insert xlDown
    Next
    Lastrow = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row
    For b = 1 To Lastrow
        If x > 4 Then x = 1
        Cells(b, 1).Value = Cells(b, 1).Value & "_0" & x
        x = x + 1
    Next
    
Application.ScreenUpdating = True
End Sub

OK

I did try this but it was not successful for me.
It increased the first row of text by 3 addition rows and added the "_01" to the first row only. The remaining text was not increased and no other digits were appended.
I did not get any error.

And to be clear, I am opening my excel file, then developer and Visual Basic. Then insert module and pasting the code in and running.