填充數組是值大於0

Question

我試圖填充值，其範圍爲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) 

它並不顯得發現任何東西>0 as kRow在看當地人窗口時爲空

什麼問題出在哪裏？

Answer 1

代碼只有在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 

Answer 2

取決於你有多少數據在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 

一種替代選項，將只需要一個數組，1循環將使用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提到你可能還需要一些數據驗證添加到測試標準，除非你知道你所有的數據是數字。