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

我在Sheet1有这个：

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

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

过滤（查找）条件：

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

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

3.忽略其内容等于 * NA * （星号NA星号） 的单元格（不论是否着色 ）。

行数是10000+，但彩色单元的数量不会超过500。

VBA代码是首选，但如果它也可以用公式完成，也是可以接受的。

这里是便于复制粘贴的示例表。

更新

单元格通过Sheet1条件格式规则进行着色。 其实Grominet的答案只适用于手动彩色的细胞 。 如何考虑条件格式的颜色？

Answer 1

我会build议循环每一行，并testing每个列到你的标准（不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