Replace all based on Cell content

[Corleone]

Hi
I would like to adjust the code below so that instead of having to type out the name in the code ie Replacement:="BOB"
it simply looks through any of the cell entries in column D (the ones highlighted in yellow) and where there are any instances that the text occurs in any of the cells in column A it strips out any other text to the left or right of it.

thanks

Sub Macro2()
'
' Macro2 Macro
'

'
Columns("A:A").Select
Selection.Replace What:="*BOB*", Replacement:="BOB", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="*FRED*", Replacement:="FRED", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="*COOPER*", Replacement:="COOPER", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
End Sub

 

[DanteAmor]

Try this:

Sub Macro1()
  Dim c As Range
  For Each c In Range("D1", Range("D" & Rows.Count).End(3))
    ActiveSheet.Range("A:A").Replace What:="*" & c.Value & "*", Replacement:=c.Value, LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
  Next
End Sub

 

[Corleone]

Try this:

Sub Macro1()
  Dim c As Range
  For Each c In Range("D1", Range("D" & Rows.Count).End(3))
    ActiveSheet.Range("A:A").Replace What:="*" & c.Value & "*", Replacement:=c.Value, LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
  Next
End Sub

Thats works! - thanks