Macro - Find Next Change In A Column; then insert row

[masterbaker]

This has to be possible and someone knows how to do it: I need a Macro that
will scan down a column and insert a row before the next change in values.
It's essentially similar to the subtotal function where you select "at each
change in:" but I need a way to break up tons of data sorted within a column
but the values are not static.

Sample Data:

Column A Column B
apple 25
apple 30
grape 26
grape 28
cherry 24
pear 27

Without knowing the actual values in column A, I need a macro that will
insert a row between apple/grape and then grape/cherry and then cherry/pear
and so on down the worksheet. I have tried a macro that uses the find
function, but I have to know what the values in column A are going to be,
which I don't.

This would be HUGE if possible. Please help!

 

[Gary Keramidas]

this may be one way, assuming the data starts in row2 of column A

Sub test()
Dim ws As Worksheet
Dim i As Long
Dim lastrow As Long
Set ws = Worksheets("sheet1")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row

For i = lastrow To 2 Step -1
With ws
If .Range("A" & i) <> .Range("A" & i - 1) Then
.Range("A" & i).EntireRow.Insert
End If
End With
Next
End Sub

 

[masterbaker]

Thanks Gary - That's Perfect

Seeing how fast you responded, could you shoot me some VB that would then
take this separated data and copy each section of similar data and paste it
into a new tab. That is, each grouping created by this blank inserted rows is
copied to a new tab until all groups are placed in new tabs.

Thanks a ton, your code is perfect!

 

[Gary Keramidas]

you can try this, probably a simpler way. watch for word wrap in the code when
you paste it.

Sub test()
Dim ws As Worksheet
Dim i As Long, cntr As Long
Dim lastrow As Long
Dim newSht As Worksheet
Set ws = Worksheets("sheet1")
lastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = lastrow To 2 Step -1
With ws
If .Range("A" & i) <> .Range("A" & i - 1) Then
.Range("A" & i).EntireRow.Insert
Else
cntr = cntr + 1
GoTo cont:
End If
cntr = 1 + cntr
Set newSht =
Worksheets.Add(after:=Worksheets(Worksheets.Count))
.Range("A" & i + 1 & ":B" & i + cntr).Copy _
newSht.Range("A1")
cntr = 0
End With
cont:
Next
End Sub

 

[Mike]

Try Sub Macro1()
'
FromCell = Cells(Rows.Count, 1).End(xlUp).Address
MsgBox FromCell
While Range(FromCell).Row <> 1
If Range(FromCell).Offset(-1, 0).Value <> Range(FromCell).Value Then
Range(FromCell).EntireRow.Insert Shift:=xlDown
FromCell = Range(FromCell).Offset(-1, 0).Address
Wend
End Sub

 

[masterbaker]

Thanks again Gary, that's also perfect. The only thing is it adds a worksheet
that is blank after every few new correct worksheets. Is there an easy way to
delete a sheet if it's completely blank?

Thanks again!