I think the logic is unnecessarily complicated
I did this as a user defined worksheet function, but the logic could be incorporated into a sub if you wanted to
I did have to add some data clean up since A5 had a trailing space which caused the logic to fail
This does NOT clean the input string (although it could) so if a two word entry has multiple spaces, it would miss
Option Explicit
Function SomeData(S As String, R As Range) As String
Dim aryData As Variant
Dim s1 As String, s2 As String
Dim i As Long, j As Long
'save data
aryData = R.Value
s1 = S
'clean data
For i = LBound(aryData, 1) To UBound(aryData, 1)
For j = LBound(aryData, 2) To UBound(aryData, 2)
'leading and trailing spaces
aryData(i, j) = Trim(aryData(i, j))
'in case there are 2 or more spaces
Do While InStr(aryData(i, j), " ") > 0
aryData(i, j) = Replace(aryData(i, j), " ", " ")
Loop
Next j
Next i
'multiple words first
For i = LBound(aryData, 1) To UBound(aryData, 1)
If InStr(aryData(i, 1), " ") > 0 Then
s2 = vbNullString
'build replacement string by going accross columns, skipping first col
For j = LBound(aryData, 2) + 1 To UBound(aryData, 2)
s2 = s2 & aryData(i, j) & " "
Next j
'remove last added space
s2 = Left(s2, Len(s2) - 1)
s1 = Replace(s1, aryData(i, 1), s2)
End If
Next i
'single words
For i = LBound(aryData, 1) To UBound(aryData, 1)
If InStr(aryData(i, 1), " ") = 0 Then
s2 = vbNullString
'build replacement string by going accross columns, skipping first col
For j = LBound(aryData, 2) + 1 To UBound(aryData, 2)
s2 = s2 & aryData(i, j) & " "
Next j
'remove last added space
s2 = Left(s2, Len(s2) - 1)
s1 = Replace(s1, aryData(i, 1), s2)
End If
Next i
SomeData = s1
End Function