Error ("Subscript Out Of Range"?) on ReDim Preserve

Question

I've gotten some great help on here, but I can't seem to use all my newfound knowledge to figure out the error in this bit of code. Anyone?

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 ActiveSheet
    For rw = .Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
        If IsEmpty(.Cells(rw, "D")) 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, "D") = Join(vSTRs, ", ")
            .Cells(rw, "D").Font.Color = vbBlue
            If dDeleteSourceRows Then _
                .Cells(rw, "D").Offset(1, 0).Resize(UBound(vSTRs) + 1, 1).EntireRow.Delete
            ReDim vSTRs(0)
        Else
            vSTRs(UBound(vSTRs)) = .Cells(rw, "D").Value2
            ReDim Preserve vSTRs(0 To UBound(vSTRs) + 1)
        End If
    Next rw
End With

End Sub

I am getting "subscript out of range" as an error, consistently. This code should be pulling data from cells D2-D39998, and concatenating it, followed by deleting the now-empty rows.

Edited to add an example what the script should be doing

Answer 1

Assuming that you have two consecutive blank cells somewhere in the list and want to skip processing the extra blank cell (row), then this check should fix that situation.

With ActiveSheet
    For rw = .Cells(Rows.Count, "D").End(xlUp).Row To 1 Step -1
        If IsEmpty(.Cells(rw, "D")) Then
            If UBound(vSTRs) > 0 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, "D") = Join(vSTRs, ", ")
                .Cells(rw, "D").Font.Color = vbBlue
                If dDeleteSourceRows Then _
                    .Cells(rw, "D").Offset(1, 0).Resize(UBound(vSTRs) + 1, 1).EntireRow.Delete
                ReDim vSTRs(0)
            End If
        Else
            vSTRs(UBound(vSTRs)) = .Cells(rw, "D").Value2
            ReDim Preserve vSTRs(0 To UBound(vSTRs) + 1)
        End If
    Next rw
End With