Sub Размножить_наименования()
Dim arrData, arrResultData
Dim lastRow As Long, i As Long, counter As Long

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    If lastRow = 1 Then
        MsgBox "На листе нет данных!", vbInformation, "Внимание"
        Exit Sub 'если на лист нет данных, то выход
    End If
    arrData = Range([A2], Cells(lastRow, "D")).Value 'берём данные с листа в массив
    Range([A2], Cells(lastRow, "D")).ClearContents 'удаляем данные с листа
    
    'считаем сколько строчек нужно будет в итоговом массиве при размножении данных
    counter = 0
    For i = 1 To UBound(arrData)
        counter = counter + CLng(arrData(i, 4))
    Next i
    ReDim arrResultData(1 To counter, 1 To 4) 'переопределяем размерность итогового массива
    
    'заполняем итоговый массив
    counter = 0
    For i = 1 To UBound(arrData)
        For n = 1 To CLng(arrData(i, 4)) 'размножаем столько раз, сколько указано в столбце D (4-й столбец)
            counter = counter + 1
            arrResultData(counter, 1) = arrData(i, 1) 'данные из столбца А
            arrResultData(counter, 2) = arrData(i, 2) 'данные из столбца В
            arrResultData(counter, 3) = arrData(i, 3) 'данные из столбца С
            arrResultData(counter, 4) = 1 'всегда 1
        Next n
    Next i
    
    'выгружаем итоговый массив на лист
    [A2].Resize(UBound(arrResultData, 1), UBound(arrResultData, 2)).Value = arrResultData

End Sub