Sub ob()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets(1)

Dim i As Long
Dim j As Long
i = 0
j = 0
Do While i <> 719999  'количество строк
    Do While sh.Cells(2 + j, 5) <> 2000  'количество строк искомых
        If sh.Cells(2 + i, 1) = sh.Cells(2 + j, 5) Then
        sh.Cells(2 + j, 6) = sh.Cells(2 + i, 2)
        End If
    j = j + 1
    Loop
i = i + 1
j = 0
Loop
End Su

Sub sovpadeniay()

Dim i As Integer
Dim j As Integer
i = 0
j = 0       'счетчик совпадений
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Лист1")
Do While sh.Cells(7 + i, 3) <> ""
 If sh.Cells(7 + i, 3).Value = sh.Cells(7 + i, 4).Value And sh.Cells(7 + i, 3).Value <> "-" Then
   j = j + 1
 End If
 i = i + 1
Loop

End Sub