VBA Search, Replace and Highlight Replaced Cell

[unknownymous]

Hi Guys,

Can you possibly help me on this? I'm trying to create a macro wherein in Column A, I need to look for these words Football, Basketball & Tennis and will replace as Sports. In column A as well, I need to look for Math and Science and replace as Subject.

I have below codes for the "Sports" and not sure on how to incorporate it for "Subject"

Sub Test()
'
Dim mapping As Object, itm As Variant


On Error Resume Next


ary = Array("Football", "Baskeball", "Tennis")
For Each wd In ary
Columns("a").REPLACE What:=wd, Replacement:="Sports", SearchOrder:=xlByColumns, MatchCase:=True


Next


Columns("A:A").Select
ActiveCell.FormulaR1C1 = ""
Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlTextString, String:="LGPSCN001", _
TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlTextString, String:="STTSTR009", _
TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.End(xlUp).Select
End Sub


This is more on recording so shortcut codes will be much appreciated.

 

[My Aswer Is This]

Try this:

Sub Replace_Me()
'Modified 11/14/2018 11:30:42 PM  EST
Application.ScreenUpdating = False
Dim r As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    For Each r In Range("A1:A" & Lastrow)
    
        With r.Value
            Select Case r.Value
                Case "Football", "Basketball", "Tennis"
                    r.Value = "Sports"
                Case "Math", "Science"
                    r.Value = "Subject"
            End Select
        End With
    Next
Application.ScreenUpdating = True
End Sub