Concatenate Columns Of Data - vba

Question

*Edited To Add: Current error I'm receiving. See bottom of this post for screenshot.
I have text in column D. The macro should find blank cells, and then concatenate the text from all cells below it.
Example
Text starting in D2, displaying like this...
Blank Cell
SampleText1
SampleText2
SampleText3
Blank Cell
SampleText4
SampleText5
SampleText6
The macro should display the text in D2...
SampleText1, SampleText2, SampleText3
and then in D6, like this...
SampleText4, SampleText5, SampleText6
..and so on.
This only needs to work in column D, so I'm guessing I can write it to that range.
The closest answer I've come across is here:
Excel Macro to concatenate
Here is the code I'm currently working with...
Sub ConcatColumns()
Do While ActiveCell <> "" 'Loops until the active cell is blank.
'The "&" must have a space on both sides or it will be
'treated as a variable type of long integer.
ActiveCell.Offset(0, 1).FormulaR1C1 = _
ActiveCell.Offset(0, -1) & " " & ActiveCell.Offset(0, 0)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Edit: Now using great code from #jeeped but receiving an error, seen in the below screenshot

Answer 1

Start from the bottom and work up, building an array of the strings. When you reach a blank cell, Join the strings using your preferred deliminator.
Sub build_StringLists()
Dim rw As Long, v As Long, vTMP As Variant, vSTRs() As Variant
Dim bReversedOrder As Boolean, dDeleteSourceRows As Boolean
ReDim vSTRs(0)
bReversedOrder = False
dDeleteSourceRows = True
With Worksheets("Sheet4")
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If IsEmpty(.Cells(rw, 1)) Then
ReDim Preserve vSTRs(0 To UBound(vSTRs) - 1)
If Not bReversedOrder Then
For v = LBound(vSTRs) To UBound(vSTRs) / 2
vTMP = vSTRs(UBound(vSTRs) - v)
vSTRs(UBound(vSTRs) - v) = vSTRs(v)
vSTRs(v) = vTMP
Next v
End If
.Cells(rw, 1) = Join(vSTRs, ", ")
.Cells(rw, 1).Font.Color = vbBlue
If dDeleteSourceRows Then _
.Cells(rw, 1).Offset(1, 0).Resize(UBound(vSTRs) + 1, 1).EntireRow.Delete
ReDim vSTRs(0)
Else
vSTRs(UBound(vSTRs)) = .Cells(rw, 1).Value2
ReDim Preserve vSTRs(0 To UBound(vSTRs) + 1)
End If
Next rw
End With
End Sub
I've left options for reversing the string list as well as removing the original rows of strings.
                  Before build_StringLists procedure
                  After build_StringLists procedure