Sub ConcatTest()
'
Dim ArrayRow As Long, OutputRow As Long
Dim BlankRows As Long, CurrentRow As Long
Dim InputArray As Variant, OutputArray() As Variant
'
InputArray = Range("C2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value2 ' Save data from sheet into InputArray
ReDim OutputArray(1 To UBound(InputArray, 1), 1 To 1) ' Set OutputArray to same # of rows as the InputArray
'
BlankRows = 0 ' Initialize BlankRows
OutputRow = 0 ' Initialize OutputRow
'
For ArrayRow = 1 To UBound(InputArray, 1) ' Loop through the rows of the InputArray
If InputArray(ArrayRow, 1) <> vbNullString Then ' If Date is not blank then ...
OutputRow = OutputRow + 1 ' Increment OutputRow
'
CurrentRow = OutputRow + BlankRows ' Get total of OutputRow + BlankRows and save to CurrentRow
OutputArray(CurrentRow, 1) = InputArray(ArrayRow, 2) ' Save Concat word to OutputArray(CurrentRow, 1)
Else ' Else ...
BlankRows = BlankRows + 1 ' Increment BlankRows
OutputArray(CurrentRow, 1) = OutputArray(CurrentRow, 1) & _
" " & InputArray(ArrayRow, 2) ' Append a space & next Concat word to OutputArray(CurrentRow, 1)
End If
Next ' Loop back
'
Range("E2:E" & Range("D" & Rows.Count).End(xlUp).Row).Value2 = OutputArray ' Display Concat word list to sheet
End Sub