将单元格值写入数组并打印数组值

Question

我正在尝试让 Sub 工作，它执行以下操作：

1. 在 F 列中搜索包含单词“Total”的单元格

2. 将找到的第一个“Total”实例的相邻单元格中的值写入数组

3. 继续在 F 列中查找“Total”并将相邻值写入数组
4. 在 Sheet2 的第二列中打印数组的值，每个值之间没有空白单元格。

到目前为止我所拥有的是：

Sub MatrixFill()
    Dim I as Integer, lrow as Long, rng as Range, cell as Range, size as Integer

    'Find # of cells in column F that have "Total" to size the array'
    size = Application.WorksheetFunction.CountIf(Range("F1:F9999"), "Total")

    'Resize the array to the amount of cells that contained "Total"'
    ReDim arrVal(1 to size) as Long

    lrow = Cells(Cells.Rows.Count, "F").End(xlUp).Row

    Set rng = Range (F1:F9999" & lrow)

    'Select the cell adjacent to each cell in the F column which contains "Total" and write to the array"
    For Each cell In rng
        If InStr(1, cell.Value, "Total", vbTextCompare) > 0  Then
            ActiveCell.Offset(1,0).Select
            arrVal(I) = ActiveCell.Value
        End If
    Next Cell

    'Write the values from the array to the second sheet in the workbook in column B'
    Sheets("Sheet2").Select
    For i = LBound(arrVal) To UBound(arrVal)
       Cells(2, 0+i).Select
       Debug.Print i, arrVal(i)
    Next i

End Sub

Answer 1

我认为您正在寻找类似以下代码的内容，请参阅代码 cmets 中的注释：

Option Explicit

Sub MatrixFill()

    Dim i As Integer, lrow As Long, Rng As Range, cell As Range, size As Integer

    'Find # of cells in column F that have "Total" to size the array'
    size = Application.WorksheetFunction.CountIf(Range("F1:F9999"), "Total")

    'Resize the array to the amount of cells that contained "Total"'
    ReDim arrVal(1 To size) As Long

    lrow = Cells(Rows.Count, "F").End(xlUp).Row

    Set Rng = Range("F1:F" & lrow)

    i = 0 ' start point array
    'Select the cell adjacent to each cell in the F column which contains "Total" and write to the array"
    For Each cell In Rng
        If InStr(1, cell.Value, "Total", vbTextCompare) > 0 Then
            i = i + 1
            arrVal(i) = cell.Offset(0, 1).Value ' <-- I think you meant to use adjacent column (not row)
        End If
    Next cell

    'Write the values from the array to the second sheet in the workbook in column B'
    Sheets("Sheet2").Range("B1").Resize(i, 1).Value = Application.Transpose(arrVal) ' <-- write the entire array at once (without a loop)

End Sub