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

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

2 answers

  • answered 2022-01-23 03:11 chris neilsen

    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))
    

  • answered 2022-01-23 09:07 VBasic2008

    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
    

How many English words
do you know?
Test your English vocabulary size, and measure
how many words do you know
Online Test
Powered by Examplum