Question

我在这里寻找我的问题的答案，但仍然，不知道如何解决它，所以我正在刷新主题。

我有一个原始函数，可以在工作表（A列）中搜索Userform.TextBox1，UserForm.Textbox2等的输入。当找到特定记录时，它应该为数组分配记录本身和来自同一行的下一个3或4个单元格的值（每行以“结束”结束）。通过这种方式，我将获得最多4列的数组，并且将找到与记录一样多的行第一个Do循环完美但增加了size变量（找到的记录），因此根据需要增加数组的行，给出了subscript out of range错误。我花了整整一天但是我没有看到我失踪的东西。这是代码：

Sub test()
Dim arr() As Variant
Dim i, size As Integer
Dim back As String
Cells(1, 1).Select
i = 0
size = 0
Do Until ActiveCell.Value = UserForm1.TextBox1.Value
  ActiveCell.Offset(1, 0).Select
Loop
back = ActiveCell.Address
Do Until ActiveCell = "End"
    size = size + 1
    ReDim Preserve arr(1 To size, 1 To 4)
    Do Until ActiveCell.Value = "End"
        i = i + 1
        arr(size, i) = ActiveCell
        ActiveCell.Offset(0, 1).Select
    Loop
Loop
Range(back).Offset(1, 0).Select
Do Until ActiveCell.Value = UserForm1.TextBox2.Value
   ActiveCell.Offset(1, 0).Select
Loop
back = ActiveCell.Address
i = 0
Do Until ActiveCell = "End"
    size = size + 1
    ReDim Preserve arr(1 To size, 1 To 4)      '"Subscript out of range" error occurs here
    Do Until ActiveCell.Value = "End"
        i = i + 1
        arr(size, i) = ActiveCell
        ActiveCell.Offset(0, 1).Select
    Loop
Loop
End Sub

Answer 1

如果您在数组 Redim 声明中使用保留关键字，则只会重新计算数组列的最后一列。您需要重新组织arr（）数组。

Answer 2

重述您的算法：

在第一列中搜索UserForm1.TextBox中的文字。这是块
每个块一直持续到"End"出现在第一列
对于块中的每一行，您需要该行中单元格的值。
包含"End"的单元格标记该行中单元格值的结尾。

我建议进行以下一般改进：

使用您无需管理元素数量的数据结构，因为这非常容易出错。使用Scripting.Dictionary，ArrayList或VBA Collection。
您不应该操纵所选单元格。定义Range并迭代Range。

像这样：

Dim text1 As String
text1 = "Alfa"
Dim text2 As String
text2 = "Kilo"

Dim results As New ArrayList

Dim rng As Range
Set rng = Worksheets("Sheet1").UsedRange

Dim row As Integer
For row = 1 To rng.Rows.Count
    Dim firstCellText As String
    firstCellText = rng(row, 1)

    'you might store the possible values in a Dictionary and use Dictionary.Exists for this check
    If firstCellText = text1 Or firstCellText = text2 Then

        Dim cellValues As ArrayList
        Set cellValues = New ArrayList 'this has to be on a separate line

        Dim cell As Range
        For Each cell In rng.Rows(row).Cells
            If cell = "End" Then Exit For
            cellValues.Add cell.Value
        Next
        results.Add cellValues
    End If
Next

ReDim VBA后，数组不会调整大小

2 个答案: