Insert Blank Row, Offset and Copy\Paste

TechTank

Board Regular
Joined
Sep 5, 2011
Messages
92
OK, so bit of a tricky one for me anyway. I have a list of data that has zero blank rows separating different values:

100
100
200
200
300
300

<tbody>
</tbody>

Now I've found this code to compare the cells above and below and where different to insert a blank row:

Code:
Sub InsertRowsAtValueChange()
'Update 20140716
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 2 Step -1
    If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
        WorkRng.Cells(i, 1).EntireRow.Insert
    End If
Next
Application.ScreenUpdating = True
End Sub

So I now have this:

100
100
200
200
300
300

<tbody>
</tbody>

What I need is some code to execute after or before but that goes to the cell above the blank row, copies the values of that cell, goes 12 columns over and pastes the data in. And this needs to happen for all the rows so it should come out looking like this:

100
100100
200
200200
300
300300

<tbody>
</tbody>

I'm not sure if that's clear enough but ask questions and I'll answer as clearly as I can.

Thanks for any help.
 
Last edited:

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sub InsertRowsAtValueChange()
'Update 20140716
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 2 Step -1
If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
WorkRng.Cells(i, 1).EntireRow.Insert

WorkRng.Cells(i + 1, 12).Value = WorkRng.Cells(i + 1, 1)

End If
Next
Application.ScreenUpdating = True
End Sub

I think all you need to do is add the line I inserted above.

I hope this helps.

ken
 
Upvote 0
TT
I oversimplified it a little. To suppress the number in column 12 for the first instance of a value, we need to check to make sure it has changed. So, the following should work a little better.

Code:
Sub InsertRowsAtValueChange()


'Update 20140716


Dim Rng As Range
Dim WorkRng As Range
Dim x As Variant


On Error Resume Next


xTitleId = "KutoolsforExcel"


Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)


Application.ScreenUpdating = False


For i = WorkRng.Rows.Count To 2 Step -1
        
    If WorkRng.Cells(i - 1, 1).Value <> WorkRng.Cells(i, 1).Value Then
        WorkRng.Cells(i, 1).EntireRow.Insert
        If x <> WorkRng.Cells(i + 1, 1) Then WorkRng.Cells(i + 1, 12).Value = WorkRng.Cells(i + 1, 1)
    End If
       
    If x <> WorkRng.Cells(i - 1, 1) Then
        WorkRng.Cells(i - 1, 12).Value = WorkRng.Cells(i - 1, 1)
        x = WorkRng.Cells(i - 1, 1)
    End If
    
Next


Application.ScreenUpdating = True


End Sub
 
Upvote 0
That works amazingly, thank you so much!

I've worked out how to add two blank rows in (which I ideally need) and would like the copied values to be placed one row below where they were before. Is that possible at all?

Also, the range to use will always be A:A so is it posible to strip out the code needed to use a selection box to specify the range or does that complicate matters? I'm guessing this is the code that is used for the selected box:
Code:
xTitleId = "KutoolsforExcel"

Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Sorry for asking more from you or anyone who follows.
 
Last edited:
Upvote 0
TT
It seems like it is already more complicated than it needs to be as far as your range identification. I would name the data area that you want to loop through something like "data"; it may be a dynamic range or a static range, but you probably don't need to be identifying it every time the code runs. I'm not sure exactly you want the values placed, but I am sure you can do it by adjusting the destination ranges (i+1 becomes i+2, maybe?). The Resize in the first IF loop makes it add two rows.
Ken

Sub test()


Set R = Range("data")


For i = R.Rows.Count To 2 Step -1

If R(i - 1, 1).Value <> R(i, 1).Value Then
R(i, 1).Resize(2, 1).EntireRow.Insert
If x <> R(i + 1, 1) Then R(i + 1, 12).Value = R(i + 1, 1)
End If

If x <> R(i - 1, 1) Then
R(i - 1, 12).Value = R(i - 1, 1)
x = R(i - 1, 1)
End If

Next


End Sub
 
Upvote 0
Here's another option
Code:
Sub InsertRowsAtValueChange()
    
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("A" & i - 1).Value <> Range("A" & i).Value Then
            Rows(i).Resize(2).Insert
            Range("M" & i).Value = Range("A" & i - 1).Value
        End If
 Next
    Application.ScreenUpdating = True
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

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