I use the code below to search and replace a part of a text in a string. It works fine for almost 97 % of the replacements but not when one string that is supposed to be replaced is identical with another part of the string. Is there a straightforward method to avoid this?

Sub Macro1()

Dim i As Integer

For i = 2 To Worksheets("table1").Range("A1").End(xlDown).Row

Worksheets("table1").Range("H:H").Replace What:=Worksheets("table2").Range("A" & i), Replacement:=Worksheets("table2").Range("B" & i), LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    
Next i

End Sub

CodePudding user response：

This is what is called a

Sheets TABLE1

Sheets TABLE1 OUTPUT

EDIT

Thank you for your wonderful solution. Problem is the delimiter is not always ",". It can also be a blank space " ". Problem using a blank space as additional delimiter might be the case that each element of the string e. g. "4711 Text_A" always has a blank space after the first 4 chars. – D3merzel 44 mins ago

In that case, you can take another approach. The text can appear in 3 positions. At the begining (TEXT & Delim), in the middle (Delim & TEXT & Delim) and in the end (Delim & TEXT)

Can you try the below code. I have not extensively tested it. If you find a scenario where it doesn't work then share it, I will tweak the code.

Option Explicit

'~~> This is the delimiter. Change as applicable
Private Const Delim As String = " "

Sub Sample()
    Dim wsTblA As Worksheet
    Dim wsTblB As Worksheet
    
    Dim lRow As Long
    Dim i As Long, j As Long

    Dim ArTable1 As Variant
    Dim ArTable2 As Variant
    
    '~~> Change this to the relevant worksheet
    Set wsTblA = Worksheets("Table2")
    Set wsTblB = Worksheets("Table1")
    
    '~~> Get the values in Col A and B from Sheet Table2 in an array
    With wsTblA
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        ArTable2 = .Range("A2:B" & lRow).Value2
    End With
    
    '~~> Get the values in Col H from Sheet Table1 in an array
    With wsTblB
        lRow = .Range("H" & .Rows.Count).End(xlUp).Row
        
        ArTable1 = .Range("H2:H" & lRow).Value2
    End With
    
    '~~> Loop through the array
    For i = LBound(ArTable2) To UBound(ArTable2)
        For j = LBound(ArTable1) To UBound(ArTable1)
            '~~> Check if the search string is present
            If InStr(1, ArTable1(j, 1), ArTable2(i, 1) & Delim, vbTextCompare) Then
                ArTable1(j, 1) = Replace(ArTable1(j, 1), ArTable2(i, 1) & Delim, ArTable2(i, 2) & Delim)
            ElseIf InStr(1, ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, vbTextCompare) Then
                ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1) & Delim, Delim & ArTable2(i, 2) & Delim)
            ElseIf InStr(1, ArTable1(j, 1), Delim & ArTable2(i, 1), vbTextCompare) Then
                ArTable1(j, 1) = Replace(ArTable1(j, 1), Delim & ArTable2(i, 1), Delim & ArTable2(i, 2))
            End If
        Next j
    Next i
    
    '~~> Write the array back to the worksheet
    wsTblB.Range("H2").Resize(UBound(ArTable1), 1).Value = ArTable1
End Sub

Sheets TABLE2

Sheets TABLE1

Sheets TABLE1 OUTPUT

CodePudding user response：

Replace in Delimited Strings

Sub ReplaceData()

    Const DST_DELIMITER As String = ", "

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
 
    ' Source
    Dim sws As Worksheet: Set sws = wb.Sheets("Table2")
    Dim srg As Range
    Set srg = sws.Range("A2:B" & sws.Cells(sws.Rows.Count, "A").End(xlUp).Row)
    Dim sDict As Object: Set sDict = TwoColumnsToDictionary(srg.Value)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets("Table1")
    Dim drg As Range
    Set drg = dws.Range("H2", dws.Cells(dws.Rows.Count, "H").End(xlUp))
    Dim dData() As Variant: dData = drg.Value
    
    ' Replace.
    ReplaceSingleColumnData dData, sDict, DST_DELIMITER
        
    ' Write.
    drg.Value = dData
        
    ' Inform
    MsgBox "Data replaced.", vbInformation

End Sub

Function TwoColumnsToDictionary( _
    ByVal Data As Variant, _
    Optional ByVal KeyColumn As Long = 1, _
    Optional ByVal ItemColumn As Long = 2, _
    Optional ByVal MatchCase As Boolean = False) _
As Object
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = IIf(MatchCase, vbBinaryCompare, vbTextCompare)
    
    Dim r As Long, kStr As String
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        kStr = CStr(Data(r, KeyColumn))
        If Len(kStr) > 0 Then dict(kStr) = CStr(Data(r, ItemColumn))
    Next r
        
    If dict.Count = 0 Then Exit Function
    
    Set TwoColumnsToDictionary = dict
    
End Function

Private Sub ReplaceSingleColumnData( _
        ByRef Data As Variant, _
        ByVal dict As Object, _
        ByVal Delimiter As String)

    Dim r As Long, n As Long
    Dim sStrings() As String, sStr As String, sFound As Boolean
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        sStr = CStr(Data(r, 1))
        If Len(sStr) > 0 Then
            sStrings = Split(sStr, Delimiter)
            For n = 0 To UBound(sStrings)
                sStr = sStrings(n) ' reusing 'sStr'
                If dict.Exists(sStr) Then
                    sStrings(n) = dict(sStr)
                    sFound = True
                End If
            Next n
            If sFound Then
                Data(r, 1) = Join(sStrings, Delimiter)
                sFound = False ' reset for the next iteration
            End If
        End If
    Next r

End Sub