Sub Test()
    Dim arrData, arrResult, i As Long, Counter As Long, arrRecord, iRow As Long, n As Long, firstRow As Long

    firstRow = 2 'начальная строка без шапки
    arrData = Range("A1").CurrentRegion.Value2
    For i = firstRow To UBound(arrData, 1)
        arrRecord = Split(arrData(i, 2), Chr(10))
        Counter = Counter + UBound(arrRecord) + 1
    Next i
    ReDim arrResult(1 To Counter, 1 To 2)
    For i = firstRow To UBound(arrData, 1)
        arrRecord = Split(arrData(i, 2), Chr(10))
        For n = 0 To UBound(arrRecord)
            iRow = iRow + 1
            arrResult(iRow, 1) = CDate(arrData(i, 1))
            arrResult(iRow, 2) = arrRecord(n)
        Next n
    Next i
    'вывод результата на лист
    Range("D2").Resize(UBound(arrResult, 1), 2).Value = arrResult
End Sub