перебор и замена в VBA

Sub tt()
    Dim a(), b(), i&
 
    With CreateObject("Scripting.Dictionary")
        a = Sheets(1).[d2].CurrentRegion.Value
 
        For i = 1 To UBound(a): .Item(a(i, 1)) = i: Next
        b = Sheets(2).[k2].CurrentRegion.Value
        For i = 1 To UBound(b)
            If .exists(b(i, 2)) Then a(.Item(b(i, 2)), 1) = b(i, 1)
        Next
 
        Sheets(1).[d2].CurrentRegion.Value = a
    End With
 
End Sub

Sub Script02()
 
    ActiveCell.Select
    Selection.Copy   ' Здесь оно копирует(выделенную) клетку D2 в буф
    
    Sheets("Лист2").Select      'Переходит на лист2 
    
    Cells.Find(What:="Test_01", After:=ActiveCell, LookIn:=xlFormulas, _      'Ищет схожее с D2 значение на листе2  
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _            
        MatchCase:=False, SearchFormat:=False).Activate                                 'Выделяет эту клетку (L2) 
    
    ActiveCell.Offset(0, -1).Range("A1").Select      'здесь оно по идеи смещается с найденой клетки L2, на K2
    
    Application.CutCopyMode = False 
    Selection.Copy                                                  'Копирует K2 в буфер
    
    Sheets("Лист1").Select          'Переходит на лист1
    
    ActiveCell.Offset(0, 1).Range("A1").Select       'смещается с клетки D2, на E2    
    
    ActiveSheet.Paste                      'Выгружет в E2 из буфура
End Sub

Sub tt()
    Dim a(), b(), i&
 
    With CreateObject("Scripting.Dictionary")
        a = Sheets(1).[d2:d3000].Value
 
        For i = 1 To UBound(a): .Item(a(i, 1)) = i: Next
        b = Sheets(2).[k2:l3000].Value
        For i = 1 To UBound(b)
            If .exists(b(i, 2)) Then a(.Item(b(i, 2)), 1) = b(i, 1)
        Next
 
        Sheets(1).[d2:d3000].Value = a
    End With
 
End Sub