Question

对于我的工作簿中的每个工作表，我想：
-检查行中是否包含颜色索引为-4142（黄色）的单元格
-如果是，则将行值复制并粘贴到“待办事项”列表中。

我尝试过：
1）对于每个循环，如下所示。
2）昏昏欲睡

For i = 1 To ThisWorkbook.Worksheets.Count
Set Sh1 = Worksheets(i)

Sub Macro1()

Dim wrk As Workbook
Dim colCount As Integer
Dim ws As Worksheet
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim r As Range, r1 As Range, cell As Range
Dim iResponse As Integer
Dim LastRow As Long

iResponse = MsgBox("Do you want to COPY your 'Current List' (Hi-lighted rows) to the 'Select List' sheet?", vbYesNoCancel + vbQuestion + vbDefaultButton3, "Copy Selected Results To View In Select List")

Select Case iResponse

Case vbCancel
    MsgBox "Cancelled", vbOKOnly + vbExclamation, "Cancelled copy"

Case vbNo: 'do Nothing
    MsgBox "Doing nothing", vbOKOnly + vbInformation, "Doing nothing"

Case vbYes

For Each ws In ActiveWorkbook.Worksheets ' For each worksheet in workbook
    Set Sh1 = Worksheets(ws.Index) ' Sh1 will be first, second, etc. worksheet
    Set Sh2 = Worksheets("ToDo")  ' sheet to copy to

    Set wrk = ActiveWorkbook ' to get header as first row
    colCount = Sh1.Cells(1, 255).End(xlToLeft).Column
    With Sh2.Cells(1, 1).Resize(1, colCount)
        .Value = Sh1.Cells(1, 1).Resize(1, colCount).Value
        .Font.Bold = True
    End With

    Set r1 = Sh1.Range(Sh1.Cells(2, "D"), Sh1.Cells(Rows.Count, "C").End(xlUp))

    For Each cell In r1
        If cell.Interior.ColorIndex = 6 Then
            If r Is Nothing Then
                Set r = cell
            Else
                Set r = Union(r, cell)
            End If
        End If
    Next

    If Not r Is Nothing Then
        LastRow = Sh2.Cells(Rows.Count, "C").End(xlUp).Row
        With Sh2
            r.EntireRow.Copy Destination:=.Range("A" & LastRow + 1)
            .UsedRange.Offset(1).Interior.ColorIndex = -4142
            Range("A1").Select
        End With

    Else
        MsgBox "No info obtained", vbExclamation, "Nothing copied."

    End If

    Exit For ' Exit For loop
Next ws ' Next worksheet

End Select

End Sub

预期输出为：
如果工作表1有3行-第1行：黄色，第2行：绿色，第3行：黄色
和工作表2有2行-第1行：黄色，第2行：蓝色
然后ToDo工作表将显示工作表1行1，工作表1行3，工作表2行2的值

当前输出为“未获取任何信息”。

Answer 1

这遍历每个工作表的已使用范围中的每个单元格。如果内部颜色匹配，它将复制该行中的所有值，并将其放入“待办事项”列表工作表中。如果循环完成后待办事项列表的行计数器没有更改，则将弹出“未获取信息”消息。

Option Explicit

Sub Test()

    Dim oToDo As Worksheet
    Set oToDo = Worksheets("ToDo")
    Dim oToDoRow As Long
    oToDoRow = 2        ' Whatever row your "todo" data starts on

    Dim oCell As Range
    Dim oCurWS As Worksheet
    Dim oPrevRow As String

    For Each oCurWS In ThisWorkbook.Worksheets
        If oCurWS.Name <> "ToDo" Then
            For Each oCell In oCurWS.UsedRange
                ' I used Interior Color you should be able to use colorindex in the same way
                If oCell.Interior.Color = 65535 Then
                    If oPrevRow <> oCurWS.Index & "_" & oCell.Row Then
                        oToDo.Rows(oToDoRow).Value = oCurWS.Rows(oCell.Row).Value
                        oPrevRow = oCurWS.Index & "_" & oCell.Row
                        oToDoRow = oToDoRow + 1
                    End If
                End If
            Next
        End If
    Next

    ' Match oToDoRow with whatever is set as default at the top
    If oToDoRow = 2 Then MsgBox "No info obtained"

End Sub

进行更新以防止在一行中突出显示多个单元格时多次列出该行。

Answer 2

您是否需要整行都为“黄色”？还是每行总有一个单元格？。

我要问的是，如果A1是黄色，B1是蓝色，C1是红色，D1是黄色，您只想从此行复制A1和D1到工作表“ ToDo”-复制到A1和B1或全部复制/粘贴行？

祝你有美好的一天

检查每个工作表是否包含某些颜色并将其粘贴到目标工作表中

2 个答案: