Excel将高亮显示/黄色的表格1和2中的所有值复制到表格3
我有一个Excel工作簿3张，前两个包含大量的数据，第三个是空白的。
我想要创build一个macros，将所有高亮/黄色单元格从表格1和2中复制并粘贴到表格3中。
我有一些代码在一分钟的macros只是复制工作表1到工作表3，但它复制一切即使我已经使用If .Interior.ColorIndex
Sub Yellow() Dim LR As Long, i As Long, j As Long j = 1 LR = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LR With Worksheets("Sheet1").Range("A1:CF200" & i) If .Interior.ColorIndex Like 27 Or 12 Or 36 Or 40 Or 44 Then .Copy Destination:=Worksheets("Sheet3").Range("J" & j) j = j + 1 End If End With Next i End Sub
更新：下面的代码修改为跳过黄色突出显示的单元格是空白的…
我可能会把这个分成两个部分，一个是循环遍历表单的函数，另一个是检查一个单元格（ Range ）是否是黄色的函数。 下面的代码有很多评论，其中包括步骤：
Option Explicit Sub PutYellowsOnSheet3() Dim Sh As Worksheet, Output As Worksheet Dim LastRow As Long, LastCol As Long Dim Target As Range, Cell As Range, Dest As Range Dim DestCounter As Long 'initialize destination counter and set references DestCounter = 1 Set Output = ThisWorkbook.Worksheets("Sheet3") 'loop through sheets that are not named "Sheet3" For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> "Sheet3" Then With Sh LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row LastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column Set Target = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)) End With For Each Cell In Target '<~ loop through each cell in the target space If AmIYellow(Cell) And Cell.Value <> "" Then '<~ blank check too Set Dest = Output.Cells(DestCounter, 1) Cell.Copy Dest DestCounter = DestCounter + 1 '<~ keep incrementing on sheet 3 End If Next Cell End If Next Sh End Sub 'call this function when you'd like to check if a range is yellow Public Function AmIYellow(Cell As Range) As Boolean If Cell Is Nothing Then AmIYellow = False End If Select Case Cell.Interior.ColorIndex '<~ this is the yellow check Case 27, 12, 36, 40, 44 AmIYellow = True Case Else AmIYellow = False End Select End Function
你的状况
.Interior.ColorIndex Like 27 Or 12 Or 36 Or 40 Or 44
总是评估为真（除0之外的任何数字都是真），所以实际上你的情况是：
'condition' Or True Or True ...
应该：
`.Interior.ColorIndex Like 27 _ Or .Interior.ColorIndex Like 12 _ Or .Interior.ColorIndex Like 36 _ Or .Interior.ColorIndex Like 40 _ Or .Interior.ColorIndex Like 44`
或更好地改写为：
Select Case .Interior.ColorIndex case 27,12,36,40,44 'action Case Else 'do nothing End Select
在你的脚本中有几个错误。 我想你想循环给定范围内的所有单元格，只复制具有指定颜色的单元格。 这可以这样做：
Sub jzz() Dim LR As Long, i As Long, j As Long Dim c As Range j = 1 LR = Range("A" & Rows.Count).End(xlUp).Row For Each c In Worksheets("Blad1").Range("A1:G" & LR) If c.Interior.ColorIndex = 6 Then c.Copy Destination:=Worksheets("Blad2").Range("A" & j) j = j + 1 End If Next c End Sub
您需要稍微修改代码，例如工作簿中不存在“Blad1”，并且仅使用ColorIndex = 6