title: Error ("Subscript Out Of Range"?) on ReDim Preserve
body: <p>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?</p>
  
  <pre><code>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
  </code></pre>
  
  <p>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.</p>
  
  <p><strong>Edited to add an example what the script should be doing</strong></p>
  
  <p><a href="https://i.stack.imgur.com/J0wVR.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/J0wVR.png" alt="enter image description here"></a></p>