Option Explicit
Sub HighlightCellsWithSameValue()
Dim rngUsedRange As Range, cell As Range
Dim x As Variant, intResponse As Long, i As Long
Dim strActSheet As String
Dim rngNewRange As Range, rngMyRange As Range
' 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
x = ActiveCell.Value
If x = Empty Then
intResponse = MsgBox("The current cell is empty. Do you wish to highlight all empty cells in the worksheet?", vbOKCancel, "Highlight Cells with Same Value")
If intResponse = vbCancel Then
GoTo endmacro
End If
End If
On Error GoTo endmacro
intResponse = MsgBox("This macro will highlight all cells with " & x & " in the current worksheet", vbOKCancel, "Highlight Cells with Same Value")
If intResponse = vbOK Then
Application.ScreenUpdating = False
strActSheet = ActiveSheet.Name
With Range([A1], [A1].SpecialCells(xlLastCell)).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Set rngUsedRange = ActiveSheet.UsedRange
Set rngMyRange = Intersect(ActiveCell.EntireColumn, rngUsedRange)
' Define area that matches selected cell value
i = 0
For Each cell In rngUsedRange
If cell.Value = x Then
If i = 0 Then
Set rngNewRange = cell
Else
Set rngNewRange = Union(rngNewRange, cell)
End If
i = i + 1
End If
Next
Set rngNewRange = Intersect(rngNewRange, rngUsedRange)
' MsgBox rngNewRange.Address
' Copy & Paste
rngNewRange.Interior.ColorIndex = 7
End If
endmacro:
Application.ScreenUpdating = True
End Sub
