Very tricky Find and Replace Strings - VBA code needed!

[actjfc]

Excel Friends:

I have list of strings in one Column, i.e. Column A, with a variable number of rows. Also, I have a Table of two columns filled with strings in each cell, let’s say Column C, and D, with a variable number of rows. The idea of the VBA macro that I would like to get help is this:

The macro should loops throughout the whole column A, any time any of the strings in a cell in Column C of the table appears inside any of the strings in column A, then the macro goes on creating a copy of the column A, in Column F, but replacing the string found with the value in Column D in the same row of the table.

For example:
Column A:The House is red
Column C - D:
House - Split Level
Red - White

Column F: The Split Level is white.

It needs to loop hundreds of rows

Thanks for any help!

 

[Caleeco]

Hello actjfc,

You weren't kidding when you said this was tricky! I have a solution for you to try:

Sub FindRep()
'Authored by Caleeco
'www.excelwtf.com


Dim arr As Variant
Dim i As Long, j As Long
Dim LoopCount As Long, StartPos As Long
Dim WordLen As Long, StrLen As Long


arr = ActiveSheet.Range("A2:E" & Range("C" & Rows.Count).End(xlUp).Row)


For i = 1 To UBound(arr)
    arr(i, 5) = ""
Next i


For i = 1 To UBound(arr) ' for each row in column A
    For LoopCount = LBound(arr) To UBound(arr) ' Loop search terms in column B
        If InStr(arr(i, 1), arr(LoopCount, 3)) > 0 Then 'If you find a match...
            
            StartPos = InStr(arr(i, 1), arr(LoopCount, 3))
            WordLen = Len(arr(LoopCount, 3))
            StrLen = Len(arr(i, 1))
            
            If StartPos = 1 Then 'if the located word is first in the string
                arr(i, 5) = arr(LoopCount, 4) & Mid(arr(i, 1), WordLen + 1)
                Range("F1").Offset(i).Value = arr(i, 5)
                arr(i, 1) = arr(i, 5)
            ElseIf StartPos = StrLen - WordLen + 1 Then 'if the located word is at the end of the string
                arr(i, 5) = Left(arr(i, 1), StartPos - 1) & arr(LoopCount, 4)
                Range("F1").Offset(i).Value = arr(i, 5)
                arr(i, 1) = arr(i, 5)
            Else  'If the located word is in the middle of the string
                arr(i, 5) = Left(arr(i, 1), StartPos - 1) & arr(LoopCount, 4) & Right(arr(i, 1), StrLen - WordLen - 3)
                Range("F1").Offset(i).Value = arr(i, 5)
                arr(i, 1) = arr(i, 5)
            End If


        End If
    Next LoopCount


Next i


End Sub

I tried it on the dataset below, and it works great. However, the find/replace is CASE SENSITIVE. I'm not sure if you can change your data to be the same case? i.e all lower case. It is dynamic in terms of processing rows ans assumes your data starts from row 2.

Excel 2010 32 bit

	A​	B​	C​	D​	E​	F​
1​	Text		Find	Replace		Output
2​	The house is red		house	split level		The split level is Black
3​	The blue car		car	Bike		The blue Bike
4​	Horse is white		Horse	Sheep		Sheep is white
5​	Sample Text		red	Black

<tbody>
</tbody>

Sheet: Sheet1

<tbody>
</tbody>

 

[Caleeco]

If this doesnt work for you, i can look into using the Replace method:
https://msdn.microsoft.com/en-us/library/office/ff194086.aspx

Might offer a more elegant solution :D

Let me know how you get on
Thanks
Caleeco

 

[actjfc]

This is a very clever solution for the way I explained. However, the actual data in column A may have many words. maybe up to 20+ per cell. So, the macro works for the specific example I provided. It is my fault! Thanks for your solution, it has a neat logic. I will see the link you provided, and keep waiting for other great ideas.

 

[Caleeco]

This is a very clever solution for the way I explained. However, the actual data in column A may have many words. maybe up to 20+ per cell. So, the macro works for the specific example I provided. It is my fault! Thanks for your solution, it has a neat logic. I will see the link you provided, and keep waiting for other great ideas.

Hi actjfc,

Thanks.. took a while to get the logic sorted!

However, I think it will still work for you... it doesnt matter if there are 100 words per cell in column a, or 20,000 rows to process... this code I posted should handle it If not, im sure one of the VBA gurus will stop by and post an alternative solution :D

Many Thanks
Caleeco

 

[mikerickson]

I think that this will work

Sub test()
    Dim StartCol As Range
    Dim MatchArray As Variant
    Dim ResultCol As Range
    Dim i As Long

    With Sheet1
        Set StartCol = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
        MatchArray = Range(.Cells(1, 3), .Cells(Rows.Count, 3).End(xlUp)).Resize(, 2).Value
        Set ResultCol = Range("F1")
    End With
    Set ResultCol = ResultCol.Resize(StartCol.Rows.Count)
    
    ResultCol.Value = StartCol.Value
    
    For i = 1 To UBound(MatchArray, 1)
        ResultCol.Replace MatchArray(1, 1), MatchArray(1, 2), MatchCase:=False, lookat:=xlPart
    Next i
End Sub

 

[mikerickson]

Darn, that should be

For i = 1 To UBound(MatchArray, 1)
    ResultCol.Replace MatchArray([U][COLOR="#FF0000"]i[/COLOR][/U], 1), MatchArray([COLOR="#FF0000"][U]i[/U][/COLOR], 2), MatchCase:=False, lookat:=xlPart
Next i

 

[actjfc]

Mike,

I cannot run your test, what I am doing wrong? I get this message:

Run time error ‘424’
Object Required at Set StartCol = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))

I am sorry for the delay in my reply. I get the logic after the fact, but my VBA knowledge comes from the trenches. So, the technical lingo is sometimes puzzling.

Thanks for your help!

 

[Peter_SSs]

I think that you will have another problem with Mike's code, assuming that you are actually trying to replace whole "words" or perhaps "phrases". For example, with your sample values in columns C:D, Mike's code will convert
The house is colored red
into
The Split Level is coloWhite White
which I doubt is what you want.

If that is an issue then you might try this code instead.

Sub Do_Replacements()
  Dim RX As Object
  Dim aData As Variant, aReplacements As Variant
  Dim i As Long, j As Long
  Dim s As String
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.IgnoreCase = True
  aData = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  aReplacements = Range("C1", Range("D" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(aData)
    s = aData(i, 1)
    For j = 1 To UBound(aReplacements)
      RX.Pattern = "\b" & aReplacements(j, 1) & "\b"
      s = RX.Replace(s, aReplacements(j, 2))
    Next j
    aData(i, 1) = s
  Next i
  Range("F1").Resize(UBound(aData)).Value = aData
End Sub

 

[mikerickson]

The line that is causing that error has to be inside a With block that refrences a worksheet.

With Sheets("Sheet1")
    Set StartCol = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
'...
End With