我怎麼能把這個添加到數組？

Question

我一直在試圖將符合高亮條件的整行添加到數組中，但我一直在努力讓它工作。

代碼循環顯示多個標識符，並根據前提條件以紅色突出顯示它們。我想將整行添加到滿足前提條件的所有行的數組中。

Sub SWAPS101() 
     'red color 
    ' If "Security Type" = SW 
    ' If "New Position Ind" = N 
' If "Prior Price" = 100 
' If "Current Price" does not equal 100 

Dim rng As Range, lCount As Long, LastRow As Long 
Dim cell As Object 

'Sheets("Output").Activate 

With ActiveSheet 

    LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 

    For Each cell In .Range("E2:E" & LastRow) 'new position 
     If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _ 
      And cell.Offset(, 4) <> 100 Then 
      With cell.EntireRow.Interior 
       .Pattern = xlSolid 
       .PatternColorIndex = xlAutomatic 
       .Color = 6382079 
       .TintAndShade = 0 
       .PatternTintAndShade = 0 
      End With 

'   LastRow = Range("b65000").End(xlUp).Row 
'    For r = 2 To LastRow 
         Row = Row + 1 
          TempArray(Row, 1) = Cells(r, cell)) 


      Next r 

     End If 
    Next cell 


End With 
End Sub 

Answer 1

使用Range.CurrentRegion property以隔離數據從A1輻射出的「島」是限制「範圍」的簡便方法的操作。您不想將數千個空白單元格複製到數組中。

Sub SWAPS101() 
     'red color 
    ' If "Security Type" = SW 
    ' If "New Position Ind" = N 
' If "Prior Price" = 100 
' If "Current Price" does not equal 100 
    Dim a As Long, r As Long, c As Long, vVALs As Variant 

    With Sheets("Output") 
     'reset the environment 
     If .AutoFilterMode Then .AutoFilterMode = False 
     .Columns(5).Interior.Pattern = xlNone 
     With .Cells(1, 1).CurrentRegion 
      ReDim vVALs(1 To .Columns.Count, 1 To 1) 
      .AutoFilter field:=Application.Match("security type", .Rows(1), 0), Criteria1:="SW" 
      .AutoFilter field:=Application.Match("new position ind", .Rows(1), 0), Criteria1:="N" 
      .AutoFilter field:=Application.Match("prior price", .Rows(1), 0), Criteria1:=100 
      .AutoFilter field:=Application.Match("current price", .Rows(1), 0), Criteria1:="<>" & 100 
      With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) 
       'check to ensure that there is something to work with 
       If CBool(Application.Subtotal(103, .Cells)) Then 
        With Intersect(.Columns(5), .SpecialCells(xlCellTypeVisible)) 
         .Cells.Interior.Color = vbRed 
        End With 
        Debug.Print .SpecialCells(xlCellTypeVisible).Areas.Count 
        With .SpecialCells(xlCellTypeVisible) 
         For a = 1 To .Areas.Count 
          Debug.Print .Areas(a).Rows.Count 
          For r = 1 To .Areas(a).Rows.Count 
           Debug.Print .Areas(a).Rows(r).Address(0, 0) 
           ReDim Preserve vVALs(1 To UBound(vVALs, 1), 1 To UBound(vVALs, 2) + 1) 
           For c = 1 To .Columns.Count 
            vVALs(c, UBound(vVALs, 2)) = _ 
             .Areas(a).Rows(r).Cells(1, c).Value 
           Next c 
          Next r 
         Next a 
         vVALs = Application.Transpose(vVALs) 
        End With 

        'array is populated - do something with it 
        Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1) 
        Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2) 
        'this dumps the values starting a couple of rows down 
        With .Cells(.Rows.Count, 1).Offset(3, 0) 
         .Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs 
        End With 
       End If 
      End With 
     End With 
     If .AutoFilterMode Then .AutoFilterMode = False 
    End With 

End Sub 

我留下了很多讓您可以觀看的過程中如何遍歷每個Range.Areas property的Range.SpecialCells method的xlCellTypeVisible集中的行debug.print語句。使用F8在瀏覽VBE的立即窗口（[Ctrl] + G）的同時單步執行代碼。

^{後處理結果}

Answer 2

可以範圍添加到一個數組，如：

Dim myArray() As Variant 'declare an unallocated array. 
myArray = Range("E2:E" & LastRow) 'myArray is now an allocated array, range being your row 

Answer 3

我的想法是創建一個聯盟範圍uRng但我不能填補它在數組中，以便創建臨時表和過去的這個範圍內它，然後填充選區（複製範圍），然後刪除此臨時表。

這個工作，但我不知道這是否是很好的方式，使這只是一個想法，因爲Jeeped answer似乎對這個問題的完整的答案

Sub SWAPS101() 
     'red color 
    ' If "Security Type" = SW 
    ' If "New Position Ind" = N 
' If "Prior Price" = 100 
' If "Current Price" does not equal 100 

Dim rng As Range, lCount As Long, LastRow As Long 
Dim cell As Range 
Dim TempArray As Variant, uRng As Range, tempSH As Worksheet 

'Sheets("Output").Activate 

With ActiveSheet 

    LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 

    For Each cell In .Range("E2:E" & LastRow) 'new position 
     If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _ 
      And cell.Offset(, 4) <> 100 Then 
      With cell.EntireRow.Interior 
       .Pattern = xlSolid 
       .PatternColorIndex = xlAutomatic 
       .Color = 6382079 
       .TintAndShade = 0 
       .PatternTintAndShade = 0 
      End With 

       If uRng Is Nothing Then 
       Set uRng = cell.EntireRow 
       Else 
       Set uRng = Union(uRng, cell.EntireRow) 
       End If 

     End If 
    Next cell 


End With 

    If Not uRng Is Nothing Then 
     Application.ScreenUpdating = False 
     Set tempSH = Sheets.Add 
     uRng.Copy 
     tempSH.Paste 
     TempArray = Selection.Value 
     Application.DisplayAlerts = False 
     tempSH.Delete 
     Application.DisplayAlerts = True 
     Application.ScreenUpdating = True 
    End If 

End Sub