Option Explicit

Sub Заполнить()
    Dim r2 As Range
    Set r2 = Sheets("Лист2").Range("D1").Resize(4501, 5001)
    
    Dim dic As Object
    Set dic = GetDic(Sheets("Sheet1"))
    
    Dim arX As Variant
    Dim arY As Variant
    Dim arr As Variant
    arX = r2.Rows(1)
    arY = r2.Columns(1)
    ReDim arr(2 To UBound(arY, 1), 2 To UBound(arX, 2))
    
    Dim sKey As String
    Dim y As Long
    Dim x As Long
    For y = 2 To UBound(arr, 1)
        Application.StatusBar = Format(y / UBound(arr, 1), "0%")
        For x = 2 To UBound(arr, 2)
            If dic.Exists(arY(y, 1)) Then
                If dic.Item(arY(y, 1)).Exists(arX(1, x)) Then
                    arr(y, x) = dic.Item(arY(y, 1)).Item(arX(1, x))
                End If
            End If
        Next
    Next
    
    r2.Cells(2, 2).Resize(UBound(arr, 1) - LBound(arr, 1) + 1, UBound(arr, 2) - LBound(arr, 2) + 1) = arr
    Application.StatusBar = False
End Sub

Function GetDic(sh As Worksheet) As Object
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, "D").End(xlUp).Row
        If y = 1 Then y = 2
        Dim d As Variant
        Dim i As Variant
        Dim m As Variant
        d = .Range(.Cells(1, "D"), .Cells(y, "D"))
        i = .Range(.Cells(1, "I"), .Cells(y, "I"))
        m = .Range(.Cells(1, "M"), .Cells(y, "M"))
    End With
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For y = 1 To UBound(d, 1)
        If Not dic.Exists(i(y, 1)) Then Set dic.Item(i(y, 1)) = CreateObject("Scripting.Dictionary")
        dic.Item(i(y, 1)).Item(m(y, 1)) = d(y, 1)
    Next
    
    Set GetDic = dic
End Function