Use Wildcards in Replace Function in combination with 2D Array Values

Question

I'm trying to go through a list with two columns and replace some of the text in the second column. I want to search for values using wildcards in combination with a value inside a 2D Array.

I've a file with all Pokemon cards separated in different worksheets by the set they're in. There are two columns that are called "Name" and "German Name".

I created another worksheet that contains all cards and their corresponding name and German name. Out of that worksheet, I create a 2 dimensional Array. This works.

Then I've loops going on and inside that I've got this line of code.

Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")

Somewhere there is the problem.

E.g. I've the entry "Bulbasaur Lv.5" in both columns and now I want to replace "Bulbasaur" in the second column with its German equivalent "Bisasam" but the "Lv.5" mustn't be touched.

The whole script.

Option Explicit

Sub firstMakro()

'Variables
Dim allSize As Integer
Dim allArray()
Dim allI As Integer
allI = 1

Dim otherSize As Integer
Dim otherI As Integer
otherI = 1

Dim i As Integer
Dim table As Integer
table = 2

'Create Array
allSize = WorksheetFunction.CountA(Worksheets("All_Pokemons").Columns(1))
ReDim allArray(allI To allSize, 1)

Do
    allArray(allI, 0) = Worksheets("All_Pokemons").Cells(allI, 1).Value
    allArray(allI, 1) = Worksheets("All_Pokemons").Cells(allI, 2).Value
    allI = allI + 1
Loop Until allI > allSize
MsgBox ("Array created")

'Replace Entries
For i = LBound(allArray, 1) To UBound(allArray, 1)
    MsgBox (allArray(i, 0))
    otherSize = WorksheetFunction.CountA(Worksheets(table).Columns(1))
    Do
        Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")
        otherI = otherI + 1
    Loop Until otherI > otherSize
    otherI = 1
Next i

End Sub

Answer 1

Replace doesn't use, or in this case even need, wildcards. Use

Replace(Worksheets(table).Cells(otherI, 2).Value, allArray(i, 0), allArray(i, 1))

Answer 2

Range Replace

• Range.Replace (Microsoft Docs)
• Tested only on a small dataset (feedback on efficiency (speed) is appreciated).
• It will replace each occurrence of an English name with the associated German name in the whole destination range.
• Adjust the values in the constants section.

Option Explicit

Sub Germanize()
    
    Const sName As String = "All_Pokemons"
    Const sfRow As Long = 2 ' ??? First Row
    Const seCol As String = "A" ' ENG
    Const sgCol As String = "B" ' GER
    
    Const dName As String = "Sheet2" ' ??? Worksheet Tab Name
    Const dfRow As Long = 2 ' ??? First Row
    Const deCol As String = "A" ' ENG
    Const dgCol As String = "B" ' GER
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source (All)
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim serg As Range: Set serg = RefColumn(sws.Cells(sfRow, seCol)) ' ENG
    If serg Is Nothing Then Exit Sub ' no data
    Dim seData As Variant: seData = GetRange(serg) ' ENG
    Dim sgrg As Range: Set sgrg = serg.EntireRow.Columns(sgCol) ' GER
    Dim sgData As Variant: sgData = GetRange(sgrg) ' GER
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim derg As Range: Set derg = RefColumn(dws.Cells(dfRow, deCol)) ' ENG
    If derg Is Nothing Then Exit Sub ' no data
    Dim dgrg As Range: Set dgrg = derg.EntireRow.Columns(dgCol) ' GER
    
    Application.ScreenUpdating = False
    
    dgrg.Value = derg.Value ' write ENG column to GER column
    
    Dim seValue As Variant
    Dim r As Long
    
    ' Replace in GER column.
    For r = 1 To UBound(seData, 1)
        seValue = seData(r, 1)
        If Not IsError(seValue) Then
            If Len(seValue) > 0 Then
                dgrg.Replace seValue, CStr(sgData(r, 1)), xlPart, , False
            End If
        End If
    Next r
    
    Application.ScreenUpdating = True
 
    MsgBox "German pokemon names updated.", vbInformation
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ?rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function