Macro pr renommer des codes sur un planning

Sub Recoder2()
Dim Rng1 As Range, Rng2 As Range
Dim L As Long
Application.ScreenUpdating = False
With Worksheets("Codes")
   Set Rng1 = .Range(.Cells(3, 1), .Cells(.Cells(.Cells.Rows.Count, 1) _
                                             .End(xlUp).Row, 2))
End With
With Worksheets("Planning").Range("B6").CurrentRegion
   Set Rng2 = Intersect(.Cells, .Offset(1, 1))
End With
For L = 1 To Rng1.Rows.Count
   Rng2.Replace What:=Rng1.Cells(L, 1), Replacement:=Rng1.Cells(L, 2), _
 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
   ReplaceFormat:=False
Next
Application.ScreenUpdating = True
End Sub

Option Explicit
Option Base 1
 
Sub TheRecoder()
Dim WSSource As Worksheet
Dim RangeSource As Range, RangeCible As Range
Dim TabSource  As Variant, TabCible  As Variant
Dim TabloSource() As String, TabloCible() As String
Dim i As Integer, ii As Integer, iii As Integer
Dim NRow As Integer, NCol As Integer
 
    Set WSSource = ThisWorkbook.Worksheets("Codes")
        With WSSource
            Set RangeSource = Range(.Range("A3"), .Range("B5000").End(xlUp))
        End With
 
    Set RangeCible = Application.InputBox(prompt:="Selectionner la Plage Planning", Type:=8)
 
    TabSource = RangeSource
    TabCible = RangeCible
 
    For i = 1 To UBound(TabSource)
        ReDim Preserve TabloSource(1 To UBound(TabSource), 2)
        TabloSource(i, 1) = TabSource(i, 1)
        TabloSource(i, 2) = TabSource(i, 2)
    Next i
 
    NRow = RangeCible.Rows.Count
    NCol = RangeCible.Columns.Count
 
    For i = 1 To NRow
        For ii = 1 To NCol
            ReDim Preserve TabloCible(1 To NRow, 1 To NCol)
            TabloCible(i, ii) = TabCible(i, ii)
            For iii = 1 To UBound(TabSource)
                If TabloCible(i, ii) = TabSource(iii, 1) Then
                    TabloCible(i, ii) = TabSource(iii, 2)
                    Exit For
                End If
            Next iii
        Next ii
    Next i
    RangeCible = TabloCible
End Sub