Конкатенатные столбцы данных

Question

* Отредактировано: Добавить текущую ошибку, которую я получаю. Смотрите снизу этого сообщения для скриншота.

У меня есть текст в столбце D. Макрос должен найти пустые ячейки, а затем конкатенировать текст из всех ячеек под ним.

Пример

Текст, начиная с D2, показывая, как это ...

Blank Cell 
SampleText1 
SampleText2 
SampleText3 
Blank Cell 
SampleText4 
SampleText5 
SampleText6 

Макрос должен отображать текст в D2 ...

SampleText1, SampleText2, SampleText3 

и затем в D6, как это ...

SampleText4, SampleText5, SampleText6 

.. и так далее.

Это должно работать только в столбце D, поэтому я предполагаю, что могу написать его в этом диапазоне.

Ближайший ответ я столкнулся здесь: Excel Macro to concatenate

Вот код, я работаю с ...

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: Теперь, используя большой код from @jeeped, но получение ошибки, см. ниже скриншот

Answer 1

Начинайте снизу и обрабатывайте, строя массив строк. Когда вы достигнете пустой ячейки, Join строк, используя ваш предпочтительный разделитель.

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 

Я оставил варианты для изменения списка строк, а также удаления исходных строк строк.

^{Перед процедурой build_StringLists}

^{После процедуры build_StringLists}