Excel 将工作表 1 和 2 中突出显示/黄色的所有值复制到工作表 3答案

【问题标题】：Excel copy all values from sheet 1 & 2 that are highlighted/yellow to sheet 3Excel 将工作表 1 和 2 中突出显示/黄色的所有值复制到工作表 3
【发布时间】：2018-05-01 16:46:54
【问题描述】：

我有一个 3 张工作表的 Excel 工作簿，前两张包含大量数据，第三张是空白的。

我想创建一个宏，从表 1 和 2 中复制所有突出显示/黄色的单元格并将它们粘贴到表 3 中。

我在宏中有一些代码，目前只是将工作表 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

【问题讨论】：

标签： vba excel copy-paste

【解决方案1】：

更新：修改以下代码以跳过黄色突出显示的空白单元格...

我可能会将它分为两个部分，一个循环遍历工作表的脚本和一个检查单元格 (Range) 是否为黄色的函数。下面的代码有很多 cmets 走过这些步骤：

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

【讨论】：

这让我得到了我想要的，你能添加到代码中以便它跳过空白（空）单元格吗？
我不确定我是否理解您的要求 - 是否存在以黄色突出显示的空白单元格？还是您希望跳过空白单元格作为性能优化？
有黄色高亮的空白单元格
啊，现在我明白了。我已经修改了上面答案中的代码以跳过空白单元格
这绝对是完美的！！我注意到输出中的顺序略有变化，这是否能够从上到下而不是从左到右扫描。所以 A1 A2 A3 A4.... B1 B2 B3 B4 等而不是 A1 B1 C1 D1 等

【解决方案2】：

您的情况
.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

【讨论】：

+1 用于在此处使用Select Case 语句，这是一个主要的行保护程序！

【解决方案3】：

您的脚本中有几个错误。我认为您想循环给定范围内的所有单元格并仅复制具有指定颜色的单元格。可以这样做：

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

【讨论】：