Delivery Notes compiler macro

I have this data , I have manually done types those results of company 1 , need macro to skin me summary , I have 500 companies do this for , macro should do the magic in time needed

03/08/2017 company 1 0316308
07/08/2017 company 1 0319068
10/08/2017 company 1 0319513
14/08/2017 company 1 0317170
17/08/2017 company 1 0317678
21/08/2017 company 1 0320083
05/08/2017 company 2 0316787
09/08/2017 company 2 0319020
12/08/2017 company 2 0316679
15/08/2017 company 2 0319868
19/08/2017 company 2 0320103
22/08/2017 company 2 0320136

COMPANY 1 0316308 DTD 03/08 , 0319068 , DTD 07/08 , 0319513 DTD 10/08 , 0317170 DTD 14/08 , 0317678 DTD 17/08 , 0320083 DTD 21/08
COMPANY 2
COMPANY 3

Expected results from above without formula since number of records per client is not known

The macro needs to read endless rows , data maybe upto 9999 records and more

Maybe:

Sub makinmombzz()
Dim i As Long, textrange As Range, x As String, xx As String, y As Long
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
Rows(1).Insert
For i = Range("B" & Rows.Count).End(3).row To 2 Step -1
    If Cells(i, "B") <> Cells(i + 1, "B") Then Rows(i + 1).Insert
Next i
For Each textrange In Columns(2).SpecialCells(2, 2).Areas
    x = ""
    addr = textrange.Address(False, False)
    For y = 1 To textrange.Rows.Count
        xx = Range(addr).Item(y, 1).Offset(, -1)
        xx = Format(xx, "dd/mm")
        x = x & Range(addr).Item(y, 2) & " DTD " & xx & ", "
        x = x
    Next y
    Range("F" & Rows.Count).End(3)(2) = Range(addr).Item(1, 1).Value
    Range("G" & Rows.Count).End(3)(2) = Left(x, Len(x) - 2)
Next textrange
Range("B1:B" & Range("A" & Rows.Count).End(3).row).SpecialCells(4).EntireRow.Delete
With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With
End Sub

or maybe so

Sub ertert()
Dim x, y(), i&, k&, s$

x = Range("A1").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To 2)

For i = 1 To UBound(x)
    If x(i, 2) <> s Then
        s = x(i, 2)
        k = k + 1
        y(k, 1) = x(i, 2)
        y(k, 2) = x(i, 3) & " DTD " & Format(x(i, 1), "dd/mm")
    Else
        y(k, 2) = y(k, 2) & ", " & x(i, 3) & " DTD " & Format(x(i, 1), "dd/mm")
    End If
Next i

Range("F1:G1").Resize(k).Value = y()
End Sub

Thank you Nilem and John , works exactly as needed

You're welcome. Glad to help out and thanks for the feedback.