Replace one text with another

[MadBern]

Hey folks,

Is this possible?
I want a particular word to be replaced by a different word in the same cell as it's written in.

Example: If someone in cell A1 types "Apples" I want the text automatically change to "Fruits".

I've tried Conditional formatting and Data validation without success.
I get to respond correctly if I type in a number, f.ex. "1" and it changes to "Fruits", but not if I type in any kind of text.

 

[MadBern]

OK for a range A1:F30 try the following code: (note i am using phone atm so can't actually test it! If it does not work and you don't have a solution already i can type one up at home when I get to my PC)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim iSect As Variant
Set rng = Range("A1:F30") 
Set iSect = Application.Intersect(rng, Target) 
    If iSect Is Nothing Then
        'do nothing
    Else
        If UCase(Target.Value) = "APPLES" Then
            Target.Value = "Fruits"
        End If
    End If
End

"Compile error: Expected end sub"

 

[tyija1995]

Ahh shoot, almost wrote it all out on phone! I guess I take for granted the automatic "End Sub" added when creating procedures!

With that code, literally just add "End Sub" right at the bottom (After End) - or change "End" to "End Sub"

 

[MadBern]

OK for a range A1:F30 try the following code: (note i am using phone atm so can't actually test it! If it does not work and you don't have a solution already i can type one up at home when I get to my PC)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim iSect As Variant
Set rng = Range("A1:F30") 
Set iSect = Application.Intersect(rng, Target) 
    If iSect Is Nothing Then
        'do nothing
    Else
        If UCase(Target.Value) = "APPLES" Then
            Target.Value = "Fruits"
        End If
    End If
End

Worked like a charm! Thank you very much

 

[tyija1995]

Worked like a charm! Thank you very much

You're welcome! I have just tested it here on PC and notice it throws errors from time to time when deleting multiple cells at once,
Try this version to eliminate the errors:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EndProcedure
Dim rng As Range
Dim iSect As Variant
Set rng = Range("A1:F30")
Set iSect = Application.Intersect(rng, Target)
    If iSect Is Nothing Then
        'do nothing
    Else
        If UCase(Target.Value) = "APPLES" Then
            Target.Value = "Fruits"
        End If
    End If
End


EndProcedure:
End


End Sub

 

[MadBern]

You're welcome! I have just tested it here on PC and notice it throws errors from time to time when deleting multiple cells at once,
Try this version to eliminate the errors:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EndProcedure
Dim rng As Range
Dim iSect As Variant
Set rng = Range("A1:F30")
Set iSect = Application.Intersect(rng, Target)
    If iSect Is Nothing Then
        'do nothing
    Else
        If UCase(Target.Value) = "APPLES" Then
            Target.Value = "Fruits"
        End If
    End If
End


EndProcedure:
End


End Sub

Yeah, I noticed that too, but I could've lived with it.
Anyway, thanks again!