Find and replace multiple values in one cell from list

Hi, I have the below code in the attached file. What I am trying to do is find and replace multiple values contained in one cell. Looking at the file, I want the company names in column A replaced with the values in column D which represent a list of the company names in column C. See cell B25 for example. I have this code written but it only replaces the first value found and deletes the rest. I would appreciate any help. Thanks in advance.

Sub String_Replacer()
    
    Dim ws As Worksheet, wb As Workbook
    Dim fList As Variant, I As Integer
    Dim rng1 As Range
    Dim rng2 As Range
    Dim cel As Range
    Dim strMyChar As String, strMyReplace As String
     
Application.ScreenUpdating = False
     
    With ActiveWorkbook.Worksheets("Sheet1")
        Set rng1 = .[C1:C2405]
    End With
    With ActiveWorkbook.Worksheets("Sheet1")
        Set rng2 = .[A1:A5115]
    End With
    
    For Each cel In rng1.Cells
        strMyChar = cel.Value
        strMyReplace = cel.Offset(0, 1).Value
        
        With rng2
            .Replace What:=strMyChar, Replacement:=strMyReplace, _
            SearchOrder:=xlByColumns, MatchCase:=True
        End With
           
    Next cel
    
Application.ScreenUpdating = True
     
End Sub

Hello,

Use this code and run the procedure, "ReplaceStrings"

It will place the results in column B then just copy and paste.

Option Explicit

Sub ReplaceStrings()
    
    Dim sh As Worksheet
    Dim rData As Range
    Dim r As Range
    Dim lRow As Long
    
    Call TurnExtrasOff
    
    
    Set sh = ActiveSheet
    lRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
    Set rData = sh.Range("C1").Resize(lRow)
   
    For Each r In rData
        Call GetString(r)
    Next
    
    Call TurnExtrasOn
    
    MsgBox "All Finished!"
    
End Sub

Sub GetString(ByVal rDataVal As Range)

    Dim rToSearch As Range
    Dim rFound As Range
    Dim strFirstAddress As String

            
    Set rToSearch = Columns("A")
    
    With rToSearch
        Set rFound = .Find(What:=rDataVal.Value, _
                           After:=rToSearch.Resize(1, 1), _
                           LookIn:=xlFormulas, Lookat:=xlPart, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, _
                           MatchCase:=True, Matchbyte:=False, _
                           SearchFormat:=False)
    
        If Not rFound Is Nothing Then
            strFirstAddress = rFound.Address
            
            Do
                Set rFound = .FindNext(rFound)
                
                If rFound.Offset(, 1).Value = vbNullString Then
                    rFound.Offset(, 1).Value = rDataVal.Offset(, 1).Value
                Else
                    rFound.Offset(, 1).Value = rFound.Offset(, 1).Value & rDataVal.Offset(, 1).Value
                End If
            Loop While Not rFound Is Nothing And rFound.Address <> strFirstAddress
        End If
    
    End With
    

    'Clean up
    Set rFound = Nothing
    Set rToSearch = Nothing
    
End Sub

Sub TurnExtrasOff()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
End Sub

Sub TurnExtrasOn()
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

Thanks

For the safety

        With rng2
            .Replace What:=strMyChar, Replacement:=strMyReplace, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
        End With

Reg A25, you have carriage return inbetween names, so it is working properly.

Thank you all. So, So helpful.

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

Thanks, I never knew how to do that