Inserting new rows based on cell value, and copying data to the new rows

[Andrew87]

Hi All,

This is my first post so go easy on me, also let me know if I am posting wrong.

I found an old thread relating to this topic that included a code however there is one change that I would like to make and my coding knowledge isn't advanced enough to figure it out.

I am trying to have a code that looks at a column, in this case column C, and if the value in a cell is, for example, '2' a new blank row gets inserted either above or below and the contents of the entire row gets copied into the new blank row giving me two identical rows, matching value in column C.

The below code does almost exactly what i need but it makes the same number of new rows with the same data as the value that appears in column C.
What i would like to do is alter the code so that I end up with a total number of rows with the same data as the value that appears in collumn C.


Sub Inert_rows_v2()
Dim r As Long

Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlDown).Row To 1 Step -1
With Cells(r, 3)
If IsNumeric(.Value) And Not IsEmpty(.Value) Then
Rows(r + 1).Resize(.Value).Insert
Range(Replace("A#:BW#", "#", r)).Copy
Range("A" & r + 1).Resize(.Value).PasteSpecial Paste:=xlPasteValues
Range("A" & r + 1).Resize(.Value).PasteSpecial Paste:=xlPasteFormats
End If
End With
Next r
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


I have attached a before and after image of what I am trying to acheive.
I hope this makes some sense.
Thanks in advance

 

[mohadin]

Hi
Welcome on board
Try this

Sub Inert_rows_v2()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlDown).Row To 1 Step -1
        With Cells(r, 3)
            If IsNumeric(.Value) And Not IsEmpty(.Value) And .Value > 1 Then
                 On Error Resume Next
                 Rows(r + 1).Resize(.Value - 1).Insert
                 Range(Replace("A#:BW#", "#", r)).Copy
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteValues
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteFormats
            End If
    End With
Next r
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[/CODE]

 

[Andrew87]

Hi
Welcome on board
Try this

Sub Inert_rows_v2()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlDown).Row To 1 Step -1
        With Cells(r, 3)
            If IsNumeric(.Value) And Not IsEmpty(.Value) And .Value > 1 Then
                 On Error Resume Next
                 Rows(r + 1).Resize(.Value - 1).Insert
                 Range(Replace("A#:BW#", "#", r)).Copy
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteValues
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteFormats
            End If
    End With
Next r
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[/CODE]

You are a champion mahadin!

Works beautifully, thank you for your reply.

 

[mohadin]

You are very welcome
And Thank you for the feedback
Be happy and safe

 

[Snakehips]

@Andrew87 I was just pipped by @mohadin in producing a near identical solution.
You may wish to consider the following which I believe will be faster.
Using xlDown in your original code means you are looping through 1 million plus rows
Using xlUp will limit to actual drows of your data in A

Sub Inert_rows_v2()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1   '<<<using xlUp  rather than xlDown
        With Cells(r, 3)
            If IsNumeric(.Value) And Not IsEmpty(.Value) And .Value > 1 Then
                 On Error Resume Next
                 Rows(r + 1).Resize(.Value - 1).Insert
                 Range(Replace("A#:BW#", "#", r)).Copy
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteValues
                Range("A" & r + 1).Resize(.Value - 1).PasteSpecial Paste:=xlPasteFormats
            End If
    End With
Next r
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Hope that helps.

 

[Andrew87]

Thanks @Snakechips I can see where you are coming from.

I had previously changed that value and yes I do believe it is slower with xlDown, I'll change it back to xlUp as the end result is the same.