根据特定条件返回彩色单元格列表

Question

我在Sheet1：

中有这个

并在Sheet2我想查找并过滤彩色数据，结果如下：

目标：返回有色单元格列表

过滤（查找）条件：

的 1。从列中返回彩色单元格（复制/粘贴确切的单元格内容） J 到 V < / em> 从Sheet1到Sheet2中的相同单元格引用。 （颜色可以用任何颜色填充）

2.对于指定范围内的每个彩色单元格，还要返回列中的单元格 E ， H ， 我 。

第3。忽略细胞（无论是否有色），其内容等于 * NA * （星号NA星号）。

行数为10000+，但有色单元格的数量不会超过500.

首选VBA代码，但如果也可以使用公式，也可以接受。

Here is the example sheet for the ease of copy pasting.

更新

单元格由Sheet1中的条件格式设置规则着色。实际上是Grominet的answer is working only for cells manually colored。如何考虑条件格式颜色？

Answer 1

我建议循环每一行，并根据您的标准测试每一列（不是NA和彩色）。如果为true，则复制彩色单元格。并添加标题行。

这里的开始代码正常工作，需要适应您的目标。

Sub test()

Dim aLine As Long
Dim aColumn As Long
Dim lastLineS2 As Long 'lastLine of sheet2
Dim test As Boolean

lastLineS2 = 3

For aLine = 3 To 100
   test = False
   For aColumn = 1 To 50
      If aColumn > 9 And aColumn < 22 Then
          If Sheets("Sheet1").Cells(aLine, aColumn).Value <> "*NA*" And Sheets("Sheet1").Cells(aLine, aColumn).Interior.Pattern <> xlNone Then
              Sheets("Sheet2").Cells(lastLineS2, aColumn) = Sheets("Sheet1").Cells(aLine, aColumn)
              test = True
          End If
      End If
   Next aColumn
   If test Then 'copy line heading
      For aColumn = 1 To 9
        Sheets("Sheet2").Cells(lastLineS2, aColumn) = Sheets("Sheet1").Cells(aLine, aColumn)
      Next aColumn
      lastLineS2 = lastLineS2 + 1
   End If
Next aLine

End Sub

Answer 2

试试这个

Sub ttt()
Dim cl As Range, n&
Sheets("Sheet1").Cells.Copy Sheets("Sheet2").Cells
Application.ScreenUpdating = 0
With Sheets("Sheet2")
    For Each cl In .UsedRange
        If cl.Row > 2 And cl.Column <> 5 And _
           cl.Column <> 8 And cl.Column <> 9 And _
           cl.Interior.Pattern = xlNone And _
           cl.Value <> "*NA*" And cl.FormatConditions.Count = 0 Then
           cl.Value = ""
        End If
    Next cl
    n = .Cells(.Rows.Count, "H").End(xlUp).Row
    While n <> 2
        If WorksheetFunction.CountA(.Range("J" & n & ":V" & n)) = 0 Then
            .Rows(n).Delete
        End If
        n = n - 1
    Wend
End With
Application.ScreenUpdating = 1
End Sub