Insert Blank Row, Offset and Copy\Paste

T

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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]100
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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:

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]200[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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.
Sort by date Sort by votes
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
You must log in or register to reply here.

Similar threads

S
  • Solved
Starting range at row 2
Replies
3
Views
403
Joe4
Joe4
G
  • Question Question
Macro is not adding blank rows
Replies
7
Views
634
Coyotex3
C
C
  • Solved
Insert row on base on cell value
2 3
Replies
29
Views
2K
chua_sb
C
B
  • Solved
VBA that adds a new row, with data from the previous row, if certain criterias are met
2
Replies
16
Views
3K
Legacy 143009
L
R
  • Question Question
VBA Question - VBA for validating value from multiple cells/column and fetching value another sheet's cell and pasting it another cell of sheet
Replies
2
Views
276
Kaper
Kaper

Forum statistics

Threads
1,223,243
Messages
6,170,971
Members
452,371
Latest member
Frana

Share this page

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