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

我已经留下了很多debug.print语句，因此您可以观察该过程如何遍历Range.Areas property的Range.SpecialCells method集合中每个xlCellTypeVisible的行。使用 F8 逐步执行代码，同时注意VBE的立即窗口（[Ctrl] + G）。

^{后处理结果}

Answer 2

您可以向数组添加范围，例如：

0.0.1

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

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

3 个答案: