Question

我正在尝试使用Sub来完成以下操作：

在列F中搜索包含“总计”
将第一个找到的“Total”实例的相邻单元格中的值写入数组
继续在F列中查找“Total”并将相邻值写入数组
在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

我认为您正在使用下面的代码，请参阅代码注释中的注释：

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

将单元格值写入阵列和打印阵列值

1 个答案: