Revised Code , forgot about "Orange" cells.
Sub MG18Mar09
Dim Rng As Range, Dn As Range, n As Long, Ac As Long, nRng As Range, Q As Variant, K As Variant
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
On Error Resume Next
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Array(Dn, 0)
Else
Q = .Item(Dn.Value)
Q(1) = 1
For Ac = 7 To 9
Q(0).Offset(, Ac).Value = Dn.Offset(, Ac).Value
Next Ac
If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
.Item(Dn.Value) = Q
End If
Next
For Each K In .keys
If .Item(K)(1) = 0 Then
If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, .Item(K)(0))
End If
Next K
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub
Regards Mick
Bookmarks