Solved: Inserting rows after highlighting a cell

[colindickson]

Hi,

I've been given this VBA to highlight new database codes added to a list... I also want it to add move the cells to right down, if that makes sense.

I've attached a before and after example.

Private Sub CommandButton2_Click()
Range("E5").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
LRA = Cells(Rows.Count, "D").End(xlUp).Row
LRB = Cells(Rows.Count, "E").End(xlUp).Row
j = 3 '
For i = 3 To LRB
comp = Application.Match(Range("e" & i), Range("D3:D" & LRA), 0)
If IsError(comp) Then Range("e" & i).Interior.ColorIndex = 6
Next i

End With

End Sub

[Bob Phillips]

Where is this new code coming from? Shouldn't A14 shift down as well?

[colindickson]

The data in column A remains static and a download of new codes is dumped into column B from an external source (using an excel add-in).

I hope that helps.

[Bob Phillips]

Sub ProcessData()
Dim rng As Range
Dim lastrow As Long
Dim startrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
startrow = 2
Do

For i = startrow To lastrow

If .Cells(i, "A").Value > .Cells(i, "B").Value Then

.Cells(i, "C").Resize(, 8).Insert shift:=xlDown
.Cells(i, "A").Insert shift:=xlDown
startrow = i + 1
Exit For
End If
Next i
Loop Until i > lastrow

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2").Resize(lastrow - 1)
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then rng.Delete shift:=xlUp
End With

Application.ScreenUpdating = True
End Sub

[colindickson]

This works like a dream thanks very much!!!

The only issue I have with this, is that if there's no new codes added to column B then it completely wipes out colemn A... is there any way just to ignore the whole process if there's no new codes been added to column B?

Thanks in advance.

[Bob Phillips]

This should sort that issue

Sub ProcessData()
Dim rng As Range
Dim lastrow As Long
Dim startrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
startrow = 2
Do

For i = startrow To lastrow

If .Cells(i, "A").Value > .Cells(i, "B").Value Then

.Cells(i, "C").Resize(, 8).Insert shift:=xlDown
.Cells(i, "A").Insert shift:=xlDown
startrow = i + 1
Exit For
End If
Next i
Loop Until i > lastrow

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2").Resize(lastrow - 1)
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing And Application.CountIf(rng, "") > 0 Then rng.Delete shift:=xlUp
End With

Application.ScreenUpdating = True
End Sub

[colindickson]

Genius - great work.

Thanks again!!!