PDA

View Full Version : [SOLVED] How to insert rows based on different values



snoopies
06-11-2005, 07:42 PM
Hi all,

I want to insert 2 rows when titles in col B are different..(pls see attached example). Please advise.

Thanks in advance!

rbrhodes
06-11-2005, 11:56 PM
Hi,

Here's one solution. It presumes that the list is serial (as in your example). Although I put in a check so that if the list is added to, the macro will account for previous 2 row spaces and still work correctly.



Sub ListSeparator()
'Presumes: list is serial or contains TWO blank rows!
Dim a As String, b As String
Dim e As Long, i As Long, l As Long, m As Long, r As Long
'Start row = 2
r = 2
'End row = last Col B row with data
e = Range("b65536").End(xlUp).Row - 2
'Loop 1 to 'e'
For i = 1 To e

'Get row 'r' and next row (r+1) values as 'a' , 'b'
a = Cells(r, 2)
b = Cells(r + 1, 2)

'If 'b'is blank skip 2 rows & increment loop counter by 2 rows & go 'next'
If b = "" Then
r = r + 3
i = i + 2
GoTo phred
End If

'Find ":" position in cell values this row and next row
l = Application.WorksheetFunction.Find(":", a)
m = Application.WorksheetFunction.Find(":", b)

'Compare two values (up to ":")
If Left(a, l) <> Left(b, m) Then
Range(Cells(r + 1, 2), Cells(r + 2, 2)).EntireRow.Insert
r = r + 2
End If
'Increment row to next row
r = r + 1
'Come here if 'b' was blank
phred:
Next
'Go home
Range("a1").Select
End Sub



Cheers,

dr

snoopies
06-12-2005, 07:03 AM
Hello, Really thanks for your advice!

How can I modify it so that it can work for selected rows only?

Bob Phillips
06-12-2005, 07:45 AM
How can I modify it so that it can work for selected rows only?

You don't say by what criteria, but this will insert rows if the text starts with 'The New'



Sub InsertRows()
Dim iLastRow As Long
Dim i As Long
Dim iPos As Long
Dim sTemp
Dim sTemp1iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
sTemp = Cells(iLastRow, "B").Value
iPos = InStr(1, sTemp, ":")
If iPos > 1 Then
sTemp = Left(sTemp, iPos - 1)
End If
For i = iLastRow - 1 To 2 Step -1
sTemp1 = Cells(i, "B").Value
iPos = InStr(1, sTemp1, ":")
If iPos > 1 Then
sTemp1 = Left(sTemp1, iPos - 1)
End If
If sTemp1 <> sTemp Then
If sTemp1 Like "The New*" Then
Cells(i + 1, "B").Resize(2).EntireRow.Insert
sTemp = sTemp1
End If
End If
Next i
End Sub

snoopies
06-12-2005, 09:18 AM
what I mean is.... If I hightlight row 100-200, the marco then just runs for 100 rows only ... hope this is clear...:doh:

Bob Phillips
06-12-2005, 09:27 AM
what I mean is.... If I hightlight row 100-200, the marco then just runs for 100 rows only ... hope this is clear...:doh:

Think so.

This code shouod do it, just change th constant kRows to your number, I tested with 20


Sub InsertRows()
Const kRows As Long = 20
Dim i As Long
Dim iPos As Long
Dim sTemp
Dim sTemp1
sTemp = Cells(kRows, "B").Value
iPos = InStr(1, sTemp, ":")
If iPos > 1 Then
sTemp = Left(sTemp, iPos - 1)
End If
For i = kRows - 1 To 2 Step -1
sTemp1 = Cells(i, "B").Value
iPos = InStr(1, sTemp1, ":")
If iPos > 1 Then
sTemp1 = Left(sTemp1, iPos - 1)
End If
If sTemp1 <> sTemp Then
Cells(i + 1, "B").Resize(2).EntireRow.Insert
sTemp = sTemp1
End If
Next i
End Sub


BTW, no need to highlight anything with this code.

snoopies
06-12-2005, 09:59 AM
Thank You very much!!