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

我在

Sheet1

：

在

Sheet2

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

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

筛选（查找）条件：

1。将彩色单元格（复制/粘贴准确的单元格内容）从列返回到从

表1

返回到

表2

中的相同单元格引用中。（颜色可以用任何颜色填充）

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

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

行数为10000+但彩色单元格的数量不会超过500个。

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

更新

---

单元格由

Sheet1

中的条件格式规则着色。事实上，格罗米内的。如何考虑条件格式颜色？

我建议循环每一行，并根据您的标准测试每一列（而不是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

子测试（）
暗线一样长
暗淡如柱
将最后一行2的尺寸调整为图纸2的最后一行的长度
作为布尔值的Dim测试
lastLineS2=3
对于aLine=3到100
测试=错误
对于A柱=1至50
如果A柱>9且A柱<22，则
如果表格（“Sheet1”）.单元格（aLine，aColumn）.Value“*NA*”和表格（“Sheet1”）.单元格（aLine，aColumn）.Interior.Pattern xlNone则
表（“表2”）。单元格（lastLineS2，aColumn）=表（“表1”）。单元格（aLine，aColumn）
测试=真
如果结束
如果结束
下一列
如果测试，则“复制行标题”
对于A列=1到9
表（“表2”）。单元格（lastLineS2，aColumn）=表（“表1”）。单元格（aLine，aColumn）
下一列
lastLineS2=lastLineS2+1
如果结束
下一行
端接头

试试这个

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

子ttt（）
尺寸cl作为范围，n&
图纸（“图纸1”）.单元格。复制图纸（“图纸2”）.单元格
Application.ScreenUpdate=0
附页（“第2页”）
对于每一个cl In.UsedRange
如果第2列>第2列和第5列_
第8列和第9列以及_
cl.Interior.Pattern=xlNone和_
cl.值“*NA*”和cl.FormatConditions.Count=0，则
cl.Value=“”
如果结束
下一个cl
n=.Cells（.Rows.Count，“H”）.End（xlUp）.Row
而n2
如果工作表function.CountA（.Range（“J”&n&“：V”&n））=0，则
.行（n）.删除
如果结束
n=n-1
温德
以
Application.ScreenUpdate=1
端接头

它不工作！你能检查一下它是否在你这边运行吗？这是我这边的工作，你能解释一下做了什么，或者没有做什么，或者消息错误吗？对不起，是的，你是对的，它工作了，但是我忘了解释我的单元格是由条件格式设置的。这就是它不起作用的原因。但是当它们被手动着色时，是的，它可以工作。如何修改它以考虑条件格式颜色？为什么不将条件测试集成到VBA代码而不是使用颜色检测？如何做到？你能编辑你的答案并整合这个条件吗？谢谢我是vba新手，完全是零初学者。不幸的是，代码没有产生任何结果。help pleasecode已使用条件格式验证进行更新，请重试