如何在VB excel中查找值並創建它們的數組？

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

您可能要檢查電池不空：

嘗試改變：

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

到：

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

順便說一句，你應該在開始時使用Option Explicit的代碼強制變量聲明。然後，您可以添加：

Dim i As Integer, 
Dim lSize As Long 

注：我已經被lSize VAR代替你dimX變種，因爲Dim dimX是讓我哭。

Answer 2

我已經重寫這段代碼optimixe即速度：

• 檢測是否有E列條目前面使用SpecialCells立即返回使用變形公式的範圍和常量
• 陣列來處理列E的使用部分的每個區域（變量爲X），然後寫入單個二維輸出陣列Y

請注意，此代碼重新生成單元格中的值，無論它們是基於常量的公式。它可以很容易地更新，通過改變

1. X = rngArea.Value2到X = rngArea.Formula
2. Y(lngRowTot) = rngArea.Value返回公式Y(lngRowTot) = rngArea.Formula

樣本輸出

代碼

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