Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cel1 As Range
If Application.Intersect(Columns("A"), Target) Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
End With
Set ws = Sheets("OpenItaly")
Set rng1 = ws.Range(ws.[a2], ws.Cells(Rows.Count, "A").End(xlUp))
Set cel1 = rng1.Find(Target.Value, , xlValues, xlWhole, xlByRows, , False)
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.FindNext(cel1)
Set rng2 = Union(rng2.EntireRow, cel1)
Loop While strFirstAddress <> cel1.Address
End If
If Not rng2 Is Nothing Then rng2.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
|