Separate Data in Range to Start and End

[DrowningInVBA]

Hello forum!

So I've been following along http://www.onlinepclearning.com/room-booking-system-vba-code-part-3/ to make a booking spreadsheet for my car rental business. Everything has been going well, slowly adjusting bits and pieces to suit my needs but now I've ran into a stumbling block in regards to how I want the data to be layed out.

Sub Bookings()'declare the variables
Dim bCell As Range, Rm As Range, Dt As Range, orange As Range
Dim dCell As Range, aCell As Range, Cl As Range, Nn As Range, ID As Range
Dim Pn As Range, Ar As Range, Dr As Range, Ad As Range, Dd As Range
Dim Fws As Worksheet, Bws As Worksheet
Dim x As Integer
Dim lastrow As Long
Dim oCell As Variant
Dim iCell As Variant


'variables
Set Fws = Sheet3 'data sheet
Set Bws = Sheet1 'bookings sheet
'set the range to loop through
lastrow = Fws.Range("R" & Rows.Count).End(xlUp).Row
Set orange = Fws.Range("R8:P" & lastrow)
'clear the values from the calendar
Bws.Range("B12:O28").ClearContents
Bws.Range("B12:O28").Interior.ColorIndex = xlNone
'filter the data to limit
FilterRng


'LOOP 1''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'set the variable for the number of rows and loop through
For x = 12 To 28
'set the vehicle variable
Set Rm = Bws.Cells(x, 1)


'LOOP 2''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'loop through column range
For Each dCell In Bws.Range(Cells(x, 2), Cells(x, 15))
If Not dCell Is Nothing Then
'set the date variable
Set Dt = Cells(11, dCell.Column)


'FIND FUNCTION''''''''''''''''''''''''''''''''''''''''
'find the Vehicles
Set aCell = orange.Find(What:=Rm, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'set the vehicle variable
Set bCell = aCell


'LOOP 3''''''''''''''''''''''''''''''''''''''''''''''
'loop through the filtered data
Do
'find the next vehicle with a booking
Set aCell = orange.FindNext(After:=aCell)
'establish the dates to add
If aCell.Offset(0, 4).Value <= Dt.Value And aCell.Offset(0, 7).Value >= Dt.Value Then
'set the variables
Set Cl = aCell.Cells(1, 4) 'status
Set Pn = aCell.Cells(1, 3) 'Passengers
Set Nn = aCell.Cells(1, 2) 'name
Set Ar = aCell.Cells(1, 6) 'Arrival Time
Set Dr = aCell.Cells(1, 9) 'Departure Time
Set Ad = aCell.Cells(1, 7) 'Arrival Details
Set Dd = aCell.Cells(1, 10) 'Departure Details
Set ID = aCell.Offset(0, -1) 'ID
'add the names and reassign after once
If oCell <> Nn Or iCell <> ID Then
dCell.Value = Nn & " " & "(" & Pn & ")" & vbCrLf & "Arrive: " & Ar & " " & Ad & vbCrLf & "Depart: " & Dr & " " & Dd
Set oCell = Nn
Set iCell = ID
End If
'add the coloring
Select Case Cl
Case "Unconfirmed"
dCell.Interior.ColorIndex = 35
Case "Confirmed"
dCell.Interior.ColorIndex = 37
Case "Servicing"
dCell.Interior.ColorIndex = 36
End Select
End If
'exit when values are found
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Else
Exit Do
End If
''''''''''''''''''''''
Loop 'LOOP 3 end
''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End If
''''''''''''''''''''''
Next dCell 'LOOP 2 end
''''''''''''''''''''''''''
Next x 'LOOP 1 end
''''''''''''''''''''''''''''
On Error GoTo 0
End Sub

https://imgur.com/a/OzObmAB

In the above code the name, arrival time and departure time fill into the planner nicely, but only on the first date in the booking. What I want to do is separate the arrival and departure info so the name and arrival is at the start of the booking and the name and departure is at the end of the booking, like so: https://imgur.com/a/McmhfO5

And then on days where the vehicle is only booked for a single day (eg the service test in the first screenshot), to show both arrival and departure in the single cell on the planner.

Any help would be greatly appreciated as I've spent the past few hours staring and trying different statements to no avail.

Cheers.