通过按钮返回有条件格式化的顺序数据

Question

需要 VBA 以返回 ECR > 30 天，其中包含 ECR 所在的“位置”。当您点击简单按钮时。程序需要扫描红色单元格并创建一个数组并将数组放入另一个工作簿。

到目前为止的代码：

Sub easy_button_2()
Dim rw As Long, c As Long, fast As String, X
fast = "Y"

With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 3")

With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 2")

    'clear any previous ECR #s/Location results
    rw = Application.Match("ECR #s", .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)), 0)
    With .Range(.Cells(rw + 24, 1), .Cells(Rows.Count, 1).End(xlUp))
        .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents
    End With
    'reset the Locations named range
    With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
        .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations"
    End With

    'cycle through the ECRs in Locations' column 1
    With .Range("Locations")
        For rw = 2 To .Rows.Count
            If .Cells(rw, 3) > 30 Or .Cells(rw, 2) = fast Then
                For c = 3 To .Columns.Count
                    If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then
                            .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _
                            Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2)
                        Exit For
                    End If
                Next c
            End If
       Next rw
    End With
End With
End With

'Workbooks.Open Filename:="C:\Users\MJ\Desktop\ECR Monitor.xlsm" 'ThisWorkbook.Activate 结束子

Answer 1

有两种不同的方法可以直接根据观察到的单元格颜色来确定条件格式规则的状态。您可以像开始那样使用AutoFilter method，也可以使用Range.DisplayFormat property 检查.Interior.ColorIndex（您过滤的是3，而不是255 )。

^{Locations 范围似乎可以扩展到第七行之外。为了将其本地化为动态更新的范围，定义的名称 Locations 将根据从 A3 扩展的单元格重新定义。}

方法一：自动筛选法

Sub easy_button_1()
    Dim rw As Long, c As Long, vr As Range

    Application.ScreenUpdating = False

    With Worksheets("sheet2")
        If .AutoFilterMode Then .AutoFilterMode = False

        'clear any previous ECR #s/Location results
        rw = Application.Match("ECR #s", .Range(.Cells(4, 1), .Cells(Rows.Count, 1).End(xlUp)), 0)
        With .Range(.Cells(rw + 3, 1), .Cells(Rows.Count, 1).End(xlUp))
            .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents
        End With

        'reset the Locations named range
        With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
            .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations"
        End With

        'AutoFilter the Locations named range
        With .Range("Locations")
            .AutoFilter Field:=2, Criteria1:=">30"
            For c = 3 To .Columns.Count
                '.AutoFilter Field:=c, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
                .AutoFilter Field:=c, Criteria1:=vbRed, Operator:=xlFilterCellColor
                If c > 3 Then
                    .AutoFilter Field:=c - 1, Criteria1:=vbGreen, Operator:=xlFilterCellColor
                    '.AutoFilter Field:=c - 1, Criteria1:=RGB(0, 255, 0), Operator:=xlFilterCellColor
                End If
                With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
                    'only attempt to transfer values if there is something visible
                    If CBool(Application.Subtotal(103, .Cells)) Then
                        For Each vr In .SpecialCells(xlCellTypeVisible)
                        'cycle through the visible rows
                        .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _
                            Array(vr.Value2, .Cells(0, c).Value2)
                        Next vr
                    End If
                End With
                If c > 3 Then .AutoFilter Field:=c - 1
                .AutoFilter Field:=c
            Next c
            .AutoFilter Field:=2
        End With

        If .AutoFilterMode Then .AutoFilterMode = False
    End With

    Application.ScreenUpdating = True

End Sub

通过重复的F8点击逐步完成上述过程以观察整个过程。

方法二：Range.DisplayFormat 属性

Sub easy_button_2()
    Dim rw As Long, c As Long

    With Worksheets("sheet2")

        'clear any previous ECR #s/Location results
        rw = Application.Match("ECR #s", .Range(.Cells(4, 1), .Cells(Rows.Count, 1).End(xlUp)), 0)
        With .Range(.Cells(rw + 3, 1), .Cells(Rows.Count, 1).End(xlUp))
            .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents
        End With

        'reset the Locations named range
        With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
            .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations"
        End With

        'cycle through the ECRs in Locations' column 1
        With .Range("Locations")
            For rw = 2 To .Rows.Count
                If .Cells(rw, 2) > 30 Then
                    For c = 3 To .Columns.Count
                        If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then
                            .Parent.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _
                                Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2)
                            Exit For
                        End If
                    Next c
                End If
            Next rw
        End With

    End With
End Sub

使用重复的 F8 轻按来逐步完成上述过程，以观察整个过程。观察 rw 和 c 的值在您循环浏览 Locations 命名范围时的变化。

^{请注意，以上两者都依赖于 vbRed 和 vbGreen 的数字颜色代码常量。如果您使用的颜色与主 RGB(255, 0, 0) 和 RGB(0, 255, 0) 不同，则必须进行调整。}

               
                         ^{按颜色过滤}

Answer 2

如果我想将此程序运行的值返回到另一个工作表或另一个工作簿上怎么办？我可以在另一个工作簿中引用数组吗？也许将数组声明为变量以引用它？

或者我必须将数组放在另一个工作表中并引用另一个工作簿吗？

Sub easy_button_2()
Dim rw As Long, c As Long, fast As String
fast = "Y"
Dim ws3 As Worksheet
Set ws3 = Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 3")
With Workbooks("ECR Log w_fast.xlsm").Sheets("Sheet 2")

    'clear any previous ECR #s/Location results
    rw = Application.Match("ECR #s", .Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)), 0)
    With .Range(.Cells(rw + 100, 1), .Cells(Rows.Count, 1).End(xlUp))
         .Resize(.Rows.Count, 2).Offset(1, 0).ClearContents
    End With
    'reset the Locations named range
    With .Range(.Cells(3, 1), .Cells(3, 1).End(xlDown))
        .Resize(.Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).Name = "Locations"
    End With

    'cycle through the ECRs in Locations' column 1
    With .Range("Locations")
        For rw = 2 To .Rows.Count
            If .Cells(rw, 3) > 30 Or .Cells(rw, 2) = fast Then
                For c = 3 To .Columns.Count
                    If .Cells(rw, c).DisplayFormat.Interior.Color = vbRed Then
                            ws3.Cells(Rows.Count, 1).End(xlUp).Resize(1, 2).Offset(1, 0) = _
                            Array(.Cells(rw, 1).Value2, .Cells(1, c).Value2)
                        Exit For
                    End If
                Next c
            End If
       Next rw
    End With
End With

结束子