Option Explicit
Sub DeleteIfSame()
Dim x As String
' Abort if a range isn't selected
If TypeName(Selection) <> "Range" Then
MsgBox "Please select a single cell", vbOKOnly + vbInformation, "Invalid Range Selection"
Exit Sub
End If
If Selection.Cells.count > 1 Then
MsgBox "Please select a single cell", vbOKOnly + vbInformation, "Invalid Range Selection"""
Exit Sub
End If
On Error GoTo endmacro
x = ActiveCell.Value
If x = "Error 2042" Then x = ActiveCell.Formula
If x = Empty Then
intResponse = MsgBox("The current cell is empty. Do you wish to delete all rows with an empty cell in the current column?", vbOKCancel, "Delete Rows If Same")
If intResponse = vbCancel Then
Exit Sub
End If
End If
intResponse = MsgBox("This macro will delete all rows with " & x & " in the current column", vbOKCancel, "Delete Rows If Same")
If intResponse = vbOK Then
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
' ActiveCell.EntireColumn.Select
With ActiveCell.EntireColumn
.AutoFilter Field:=1, Criteria1:=x
Rows("2:65536").SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
endmacro:
Application.Calculation = xlCalculationAutomatic
End Sub