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