如何一次性查找多个区域，并将符合条件的数据填上颜色并逐一复制到指定位置。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, k&, m, n&, iRow&, Rng As Range, isFlag As Boolean, iColor&
    Application.ScreenUpdating = False
    ar = [A35:E40].Value
   
    Range("A50:A" & Rows.Count).Clear
    With [A1].CurrentRegion
        br = .Value
        .Interior.Color = xlNone
        iColor = 3
        For m = 1 To UBound(ar, 2)
            iColor = iColor + 1
            If iColor = 57 Then iColor = 4
            For j = 1 To UBound(br, 2)
                For i = 1 To UBound(br) - UBound(ar) + 1
                    Set Rng = .Cells(i, j).Resize(UBound(ar))
                    cr = Rng.Value
                    isFlag = True
                    For n = 1 To UBound(cr)
                        If cr(n, 1) <> ar(n, m) Then isFlag = False: Exit For
                    Next n
                    If isFlag Then
                        Rng.Interior.ColorIndex = iColor
                        iRow = iRow + 1
                        Rng.Copy Cells((iRow - 1) * 10 + 50, 1)
                    End If
                Next i
            Next j
        Next m
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

xdychina1

都是好贴，感谢分享