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

Andrew87

New Member
Joined
May 20, 2023
Messages
3
Office Version
  1. 2016
Platform
  1. Windows
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 :)
 

Attachments

  • Excell sample.PNG
    Excell sample.PNG
    11.1 KB · Views: 58
  • Excell sample result.PNG
    Excell sample result.PNG
    12.6 KB · Views: 57

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Hi
Welcome on board
Try this
VBA Code:
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]
 
Upvote 1
Solution
Hi
Welcome on board
Try this
VBA Code:
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.
 
Upvote 0
You are very welcome
And Thank you for the feedback
Be happy and safe
 
Upvote 0
@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

VBA Code:
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.
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top