Sub zagr()
    Application.ScreenUpdating = 0
    r1_ = Cells(Rows.Count, 1).End(3).Row 'последняя заполненная ячейка
    If r1_ > 1 Then
        Cells(2, 1).Resize(r1_ - 1, 3).Clear 'очистка предыдущего диапазона
    End If
    arn = Sheets("Нужно").Range("A1").CurrentRegion.Offset(1).Value 'массив Нужно, нижняя строка лишняя
    are = Sheets("Есть").Range("A1").CurrentRegion.Offset(1).Value 'массив Есть, нижняя строка лишняя
    arm = Sheets("Нужно").Range("A1").CurrentRegion.Offset(1).Value 'Массив Можем (ненужное там потом изменим)
    Set slov = CreateObject("Scripting.Dictionary") 'словарь
    With slov
        For i = 1 To UBound(are) - 1 'цикл по Есть
            .Item(are(i, 1)) = are(i, 2) 'заполняем словарь
        Next i
        For j = 1 To UBound(arn) - 1 'цикл по Нужно
            ne_ = .Item(arn(j, 2)) 'сколько осталось
            If ne_ > 0 And arn(j, 3) Then 'если осталось >0 и нужно не 0, то
                k_ = k_ + 1 'счетчик +1
                If ne_ > arn(j, 3) Then 'если осталось больше, чем нужно
                    arm(k_, 3) = arn(j, 3) 'пишем из Нужно
                Else 'иначе
                    arm(k_, 3) = ne_ 'пишем сколько осталось
                End If
                arm(k_, 2) = arn(j, 2) 'заполняем второй столбец
                arm(k_, 1) = arn(j, 1) 'и первый столбец
                .Item(arn(j, 2)) = ne_ - arn(j, 3) 'в словаре уменьшаем соотв. количество
            End If
        Next j
    End With
    Cells(2, 1).Resize(k_, 3) = arm 'выгружаем на лист только нужный кусок массива
    Application.ScreenUpdating = 1
End Sub