Multiple Lookup in string and replace from a available list

[kuldeepjainesl]

Hello,

I have three columns. First is the list of values to be find. 2nd column has the values to be replaced in reference to 1st column. 3rd column contains the strings in which the values from 1st column is expected to be found in a random order and to be replaced.


As a result, we want a new list from 3rd column which find values from 1st column and replace values from 2nd column. Sample file is attached.

I thought this would be easier in VBA thus putting in VBA forum however if the formula approach is also available, I can adopt that too.

 

[jindon]

Assuming List1 is in col.A

Sub test()
    Dim a, i As Long
    a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
    For i = 2 To UBound(a, 1)
        Columns(3).Replace a(i, 1), a(i, 2), 2
    Next
End Sub

 

[kuldeepjainesl]

Working . thanks, Can you add the colour as well to the replaced text as done in sample file. it will help to identify the changes

 

[jindon]

Sub test()
    Dim a, i As Long, myPtn As String, r As Range, m As Object
    a = Cells(1).CurrentRegion.Resize(, 2).Value
    Columns("c").Font.ColorIndex = xlAutomatic
    For i = 2 To UBound(a, 1)
        Columns("c").Replace a(i, 1), a(i, 2), 2
    Next
    myPtn = Join(Application.Transpose(Range("b1", Range("b" & Rows.Count).End(xlUp))), Chr(2))
    With CreateObject("VBScript.RegExp")
        .Global = True: .IgnoreCase = True
        .Pattern = "([$()^|\\\[\]{}+*?.-])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = myPtn
        For Each r In Range("c2", Range("c" & Rows.Count).End(xlUp))
            For Each m In .Execute(r.Value)
                r.Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
            Next
        Next
    End With
End Sub

 

[kuldeepjainesl]

Great ! Worked like a charm. thank you.

 

[kuldeepjainesl]

I have a problem. i was using this code under the file attached and it worked like a charm until i did not added more data on sheet.
what the code does : it lookup the string in 3 coloum and take a match from 1& 2nd coloum and replace the values. It also change the colour of the replaced values. now it has started g giving error. Please refer the file and help.

i am not able to attach error image thus giving link by uploading image at drive. https://1drv.ms/i/s!Apd3cKWHmI43g0qfm4P5Fo-4pEQZ

 

[jindon]

If the data always like uploaded file(row to row) then

Sub test1()
    Dim r As Range
    For Each r In Cells(1).CurrentRegion.Offset(1).Cells
        If r <> "" Then
            r(, 3) = Replace(r(, 3), r, r(, 2))
            x = InStr(r(, 3), r(, 2))
            If x > 0 Then r(, 3).Characters(x, Len(r(, 2))).Font.Color = vbRed
        End If
    Next
End Sub

 

[kuldeepjainesl]

No it would not be row to row. the first two coloum to be referred as master data and C coloum can have any sequence. Any number at any place. this file was just made for visualization.

 

[jindon]

No it would not be row to row. the first two coloum to be referred as master data and C coloum can have any sequence. Any number at any place. this file was just made for visualization.

Never do like this as we are working based on the workbook provided.
Workbook should clearly show us the problem and the result that you want.

I can not replicate the error you showed, so no idea.

 

[kuldeepjainesl]

Does the file at your system is working fine and replaced the string and change the color? i also tried by reducing the the master data and it found to be working with 6000 rows in master data. Currently i have ~14K row in master data and facing error as shown in image. to me it disconnect the VBA from excel as after this error you can not run this code any more unless you reopen the excel file.

Let me post a actual version of file to work on....

 

[jindon]

Takes time due to the number of rows to replace, but works fine here.
A bit faster than Replace method in this case.

Sub test()
    Dim a, i As Long, myPtn As String, r As Range, m As Object, dic As Object
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = Cells(1).CurrentRegion.Resize(, 2).Value
    Columns("c").Font.ColorIndex = xlAutomatic
    For i = 2 To UBound(a, 1)
        If a(i, 1) <> "" Then dic(a(i, 1)) = a(i, 2)
    Next
    myPtn = Join(dic.keys, Chr(2))
    a = Cells(1).CurrentRegion.Columns(3).Value
    With CreateObject("VBScript.RegExp")
        .Global = True: .IgnoreCase = True
        .Pattern = "([$()^|\\\[\]{}+*?.-])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myPtn & ")\b"
        For i = 2 To UBound(a, 1)
            For Each m In .Execute(a(i, 1))
                a(i, 1) = .Replace(a(i, 1), dic(m.Value))
            Next
        Next
        Cells(1).CurrentRegion.Columns(3).Value = a
        myPtn = Join(Application.Transpose(Range("b1", Range("b" & Rows.Count).End(xlUp))), Chr(2))
        .Pattern = "([$()^|\\\[\]{}+*?.-])"
        myPtn = Replace(.Replace(myPtn, "\$1"), Chr(2), "|")
        .Pattern = "\b(" & myPtn & ")\b"
        For Each r In Range("c2", Range("c" & Rows.Count).End(xlUp))
            For Each m In .Execute(r.Value)
                r.Characters(m.firstindex + 1, m.Length).Font.Color = vbRed
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 

[kuldeepjainesl]

Thank you for your effort jindon but i am sorry that the error is now just pop up as you press the macro "Run" Earlier it was after the replacement of string and just at the time when we tried to change their color. Now it just gives error and do nothing. Might be some issue on my PC. i am using Excel 2013 , 64 Bit.

The error is same as given in above screenshot.

 

[jindon]

Mine is xl2013 32Bit, working fine for both 1st and the last code I have posted.
Try create a new workbook and copy the data.
If still error, something might be wrong with your Excel.