Excel 使用大于0的值填充数组

我试图用

dataRange

范围内的值填充数组，这些值是

>0

，但它不能正常工作

Dim kRow As Variant, cell As Range, dataRange As Range
Set dataRange = ws.Range("AE4", ws.Range("AE4").End(xlDown))

ReDim kRow(0)
For Each cell In dataRange
    If cell.Value > 0 Then
        kRow(UBound(kRow)) = cell.Value
        ReDim Preserve kRow(UBound(kRow) + 1)
    End If
Next cell
ReDim Preserve kRow(UBound(kRow) - 1)

当查看“本地人”窗口时，由于

kRow

为空，因此它似乎没有找到任何

>0

---

出了什么问题？

只有在AE4中找不到任何值时，代码才会出现问题

然后，

ReDim Preserve kRow（UBound（kRow）-1）

这一个抛出一个错误

通常，将一些值放在列

A

中，然后尝试一下：

Option Explicit

Public Sub TestMe()

    Dim kRow As Variant, cell As Range, dataRange As Range
    Dim i As Long

    Set dataRange = ActiveSheet.Range("A4", ActiveSheet.Range("A4").End(xlDown))

    ReDim kRow(0)
    For Each cell In dataRange
        If cell.Value > 0 Then
            kRow(UBound(kRow)) = cell.Value
            ReDim Preserve kRow(UBound(kRow) + 1)
        End If
    Next cell

    For i = LBound(kRow) To UBound(kRow)
        Debug.Print kRow(i)
    Next i

    'ReDim Preserve kRow(UBound(kRow) - 1)

End Sub

---

根据您在

dataRange

中拥有的数据量，加载到临时数组并进行处理可能比在工作表上循环单元格更快。另外，

ReDim Preserve

是一项昂贵的操作，因此最好尽可能避免

下面的代码将

dataRange

存储在临时数组中，循环临时数组以查找匹配项并存储行索引号，重新调整

kRow

的大小以适应，然后复制匹配值

Sub PopulateArray()

    Dim ws As Worksheet
    Dim dataRange As Range
    Dim temparr() As Variant, kRow() As Variant
    Dim i As Long, InstanceCount As Long
    Dim RwIndexList As String, Rw As Variant

    Set ws = Sheet1
    Set dataRange = ws.Range("AE4", ws.Range("AE4").End(xlDown))

    'store dataRange in 1D array for processing
    temparr = Application.Transpose(dataRange.Value)

    'loop to determine # of instances > 0
    For i = LBound(temparr) To UBound(temparr)

        If temparr(i) > 0 Then RwIndexList = RwIndexList & "_" & i

    Next i

    'only process if matches found
    If Not RwIndexList = vbNullString Then

        'determine # of matches
        InstanceCount = Len(RwIndexList) - Len(Replace(RwIndexList, "_", ""))

        'resize kRow to match # of instances > 0
        ReDim kRow(1 To InstanceCount)

        'initialize kRow counter
        i = 1

        'copy matching rows to kRow
        For Each Rw In Split(Mid(RwIndexList, 2), "_")

            kRow(i) = temparr(Rw)
            i = i + 1

        Next Rw

    End If

End Sub

另一个只需要一个数组和一个循环的选项是使用

Application.Index

对数组进行切片以过滤掉不匹配的行；但是，这只适用于二维数组，因此您将保留一个二维数组作为输出，不确定这是否是您的选项

Sub PopulateArray_Alternative()

    Dim ws As Worksheet, dataRange As Range
    Dim kRow() As Variant, i As Long, RwIndexList As String

    Set ws = Sheet1 'change to suit
    Set dataRange = ws.Range("AE4", ws.Range("AE4").End(xlDown))

    'store dataRange in 2D array for processing
    kRow = dataRange.Value

    'store matching rows in index list
    For i = LBound(kRow) To UBound(kRow)

        If kRow(i, 1) > 0 Then RwIndexList = RwIndexList & "_" & i

    Next i

    'only process if matches found
    If Not RwIndexList = vbNullString Then

        'slice array to filter non-matching rows
        kRow = Application.Index(kRow, Application.Transpose(Split(Mid(RwIndexList, 2), "_")), 0)

    End If

End Sub

---

正如@Peh所提到的，除非您知道所有数据都是数字，否则您可能还希望在测试标准中添加一些数据验证。

您确定吗？使用

Debug.Print UBound（kRow）

作为最后一条语句对其进行测试结果是什么？代码对我来说很好，没有问题。您确定

cell.Value

是数字而不是文本吗？虽然我使用了不同的范围声明，但代码也适用于我。如果您的范围声明有效，那么代码的其余部分也应该有效。要验证

ws.range（“AE4”）.End（xlDown）

是否确实是您想要的，请手动选择AE4并按ctrl+down（箭头向下）键。现在选择的单元格是从AE4开始的

dataRange

的最后一个单元格。如果您指的是AE列中的最后一个单元格，请使用

Set dataRange=ws.Range（“A4”，ws.Range（“A”&ws.Rows.Count”）.End（xlUp））

。