Concatenate With Loop Through 2 Columns of Information

Hi Thanks for any help in advance.
I have a list of names with blank cells in Column A cell 2.
I want the programme to scroll through this column until it finds a name, when it does I want it to look in cell offset(1, 1), in this case B3 to see if there is a number. I want this number to be moved to offset (0, 1) AND any subsequent numbers below it until the next blank cell in that column (B).
In the attached image cell B2 will contain all numbers in cells B3:B9 with a / between them. Cell B10 will have number from B11 and B12 will have B13:B15. If there is no number it will just continue to the next name in column A. My rough code below delivered the first number only in the relevant cell and I'm not clever enough to get it right. It does not have to be super slick as it's for one time use. Again thank you ;-)
Sorry forgot to say I need numbers in column B cleared as they are concatenated into the single cell.

Spreadsheet.jpg

Sub Concatene()
Dim rng As Long
Dim r As Integer

  For r = 2 To 9440
 Cells(r, 1).Select
 If Selection <> "" Then If Selection.Offset(1, 1) <> 0 Then Selection.Offset(0, 1) = Selection.Offset(0, 1) & "/" & Selection.Offset(1, 1)
 
 Next
 
End Sub