我怎么能把这个添加到数组？

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