Speed Up Characters replacement VBA

Question

I have this little code that replaces the letters from a table like this (find the left string and replace it with the right string):

However it takes a great amount of time to do all the replacements in the sheets I have (just 2). Nearly 10 seconds. Is there a way to speed this up pls? Many thanks for taking the time!!

Dim sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim ReplaceCount As Long

Set sht = Sheets("Sheet1")
Application.ScreenUpdating = False

'Create variable to point to your table
Set tbl = Worksheets("Sheet1").ListObjects("StringReplace")

'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
  
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2

'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)

'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name <> tbl.Parent.Name Then
            sht.Cells.Replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
            SearchFormat:=False, ReplaceFormat:=False
            
        End If
    Next sht
Next x
Application.ScreenUpdating = True

Answer 1

Replace Strings in Multiple Worksheets

The Code

Option Explicit

Sub replaceOddStrings()
    
    Const WorksheetName As String = "Sheet1"
    Const TableName As String = "StringReplace"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim Data As Variant: Data = wb.Worksheets(WorksheetName) _
        .ListObjects(TableName).DataBodyRange.Value
    
    Dim ws As Worksheet
    Dim i As Long
    
    Application.ScreenUpdating = False
    For Each ws In wb.Worksheets
        If ws.Name <> WorksheetName Then
            For i = 1 To UBound(Data, 1)
                ws.UsedRange.Replace Data(i, 1), Data(i, 2), xlPart, , False, _
                    False, False, False
            Next i
        End If
    Next ws
    Application.ScreenUpdating = True

    MsgBox "Strings replaced.", vbInformation, "Success"
 
End Sub