Question

我遇到了这个问题。我必须在一个column ("E")中找到非空白单元格并将它们放在一个数组中，然后列出该数组。我试过这个，但阵列没有正确填充

    Dim k As Integer
    Dim X() As String

    k = 0
    dimX = Application.CountA(Range("E2:E2498")) 
    ReDim X(1 To dimX)

    For i = 2 To 2498
     If IsEmpty(Cells(i, "E")) Then
      k = k + 1
      X(k) = Cells(i, "E").Value
     End If
    Next i

Answer 1

我已经重写了这段代码来优化速度：

测试前面是否有任何E列条目
使用SpecialCells立即返回公式和常量的范围
使用变量数组处理E列的已用部分的每个区域（X变量），然后写入单个dimesion输出数组Y

请注意，此代码从单元格重新生成值，无论它们是基于常量的公式。可以通过更改

轻松更新以返回公式

X = rngArea.Value2至X = rngArea.Formula
Y(lngRowTot) = rngArea.Value至Y(lngRowTot) = rngArea.Formula

示例输出

code sample

代码

    Sub GetEm()
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rngFinal As Range
    Dim rngArea As Range
    Dim X
    Dim Y
    Dim lngRow As Long
    Dim lngRowTot As Long

    'early exit if there are no values
    If Application.CountA(Columns("E")) = 0 Then
        MsgBox "Column E has no formulae or constants", vbCritical
        Exit Sub
    End If

    'quickly determine the range of constants and formulae
    On Error Resume Next
    Set rng1 = Columns("E").SpecialCells(xlFormulas)
    Set rng2 = Columns("E").SpecialCells(xlConstants)
    On Error GoTo 0
    If Not rng1 Is Nothing Then
        If Not rng2 Is Nothing Then
            Set rngFinal = Union(rng1, rng2)
        Else
            Set rngFinal = rng1
        End If
    Else
        Set rngFinal = rng2
    End If

    ReDim Y(1 To 100)

    'Look at each range area (data may not be continuous)
    For Each rngArea In rngFinal.Areas
    'Use variant arrays to popluate a single dimension string array
        If rngArea.Cells.Count > 1 Then
            X = rngArea.Value2
            For lngRow = 1 To UBound(X)
                lngRowTot = lngRowTot + 1
                If lngRowTot Mod 100 = 0 Then ReDim Preserve Y(1 To (UBound(Y) + 100))
                Y(lngRowTot) = X(lngRow, 1)
            Next
        Else
        'handle single cells
            lngRowTot = lngRowTot + 1
            If lngRowTot Mod 100 = 0 Then ReDim Preserve Y(UBound(Y) + 100)
            Y(lngRowTot) = rngArea.Value
        End If
    Next

    'cut down array to require size
    ReDim Preserve Y(1 To lngRowTot)
    MsgBox Join(Y, ", "), , "Your array is"
End Sub

Answer 2

您可能想要检查单元格是否为空：

尝试改变：

If IsEmpty(Cells(i, "E")) Then

为：

If Not IsEmpty(Cells(i, "E")) Then

顺便说一句，您应该在代码开头使用Option Explicit 强制变量声明。然后你会添加：

Dim i As Integer,
Dim lSize As Long

注意：我已将dimX var替换为lSize var，因为Dim dimX让我哭了。

如何在VBA excel中查找值并创建它们的数组？

2 个答案: