Перенос повторяющихся строк двух листов на 3 лист

Sub Lst()
  Dim Ar1(), Ar2()
  Dim i As Long, j As Long
  Dim Dk As Object
  Set Dk = CreateObject("Scripting.Dictionary")
  With Worksheets("Лист1")
      For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
         Dk.Add .Cells(i, 2).Value, .Cells(i, 3).Value
      Next
  End With
  Ar1 = Worksheets("Лист2").Range("B1:B9910").Value
  j = 1
  ReDim Ar2(1 To 700, 1 To 2)
  For i = 1 To UBound(Ar1)
       If Dk.Exists(Ar1(i, 1)) Then
           Ar2(j, 1) = Ar1(i, 1)
           Ar2(j, 2) = Dk.Item(Ar1(i, 1))
           j = j + 1
        End If
   Next
 Worksheets("Лист3").Range("B2:C" & UBound(Ar2) + 1).Value = Ar2
End Sub

Sub Lst2()
  Dim Ar1(), Ar2()
  Dim Ar3() As String
  Dim i As Long, j As Long
  Dim Dk As Object
  Set Dk = CreateObject("Scripting.Dictionary")
  With Worksheets("Лист1")
      For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
         Dk.Add .Cells(i, 2).Value, .Cells(i, 3).Value
      Next
  End With
  Ar1 = Worksheets("Лист2").Range("B1:B9909").Value
  j = 1
  ReDim Ar2(1 To 700, 1 To 2)
  For i = 1 To UBound(Ar1)
       Ar3 = Split(Ar1(i, 1))
       If Dk.Exists(Ar3(3)) Then
           Ar2(j, 1) = Ar3(3)
           Ar2(j, 2) = Dk.Item(Ar3(3))
           j = j + 1
        End If
   Next
 Worksheets("Лист3").Range("B2:C" & UBound(Ar2) + 1).Value = Ar2
End Sub