ReDim Preserve上的错误（＆＃34;下标超出范围＆＃34;？）

Question

我在这里得到了一些很好的帮助，但我似乎无法利用我所有新发现的知识来弄清楚这段代码中的错误。任何人吗？

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

我得到＆＃34;下标超出范围＆＃34;作为一个错误，始终如一。此代码应该从单元格D2-D39998中提取数据，并将其连接起来，然后删除现在为空的行。

编辑添加脚本应该执行的示例

Answer 1

假设您在列表中的某个位置有两个连续的空白单元格，并且想要跳过处理额外的空白单元格（行），那么此检查应该可以解决这种情况。

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