將Sheet1第2行中的黃色單元格依次復制到Sheet2

Question

我想搜索“ In Motion”工作表第2行中的單元格。 如果一個單元格突出顯示為黃色，我想復制整個列並將其粘貼到工作表“儀表板”中。 我希望重復此操作以找到“運動”的第2行中的每個黃色單元格。 我還希望這些列按順序粘貼到“儀表盤”上。

我的代碼（部分是通過運行宏構建的）無法正常工作。 它確實復制在“運動中”找到的第一個黃色單元格的列，並粘貼到“儀表板”的A1中。 但是，它不會循環遍歷第2行中的所有單元。它只是停止了。

另外，我認為如果循環正常運行，我的代碼將無法有效地將列順序依次粘貼到“儀表板”中。 我認為他們都將粘貼到A1。

對不起，菜鳥問題。 非常感謝您的幫助！

Sub AutoPopulateNew()
Dim C As Range

'Clear Dashboard
Worksheets("Dashboard").Activate
Worksheets("DashBoard").Cells.ClearContents

'Move to In Motion Sheet
Worksheets("In Motion").Activate

'Find and copy yellow highlighted cells
For Each C In Worksheets("In Motion").Rows("2:2")
    C.Select
        With Application.FindFormat.Interior.Color = 65535
        End With
    Selection.Find(What:="", LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchFormat:=True).Activate
    ActiveCell.EntireColumn.Copy _
        Destination:=Worksheets("Dashboard").Range("A1")
    Next C

Worksheets("Dashboard").Activate

End Sub

Answer 1

您無需激活工作表即可在其中進行書寫。 我喜歡使用RGB聲明顏色，並且（255,255,0）是黃色。 您也可以改用vbYellow。 要找出任何顏色的RGB數字，請選擇該單元格，轉到為背景着色的桶圖標，選擇更多顏色，然后自定義以查看RGB數字。 此代碼將執行此操作，並根據需要進行編輯。

Sub AutoPopulateNew()
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim c As Range

'Clear Dashboard sheet
Worksheets("DashBoard").Cells.ClearContents

count = 1 'counts the cells with a matching background color

'Loop through the cells and check if the background color matches
For Each cell In Worksheets("In Motion").Rows(2).Cells
    If cell.Interior.Color = RGB(255, 255, 0) Then
        Worksheets("Dashboard").Cells(1, count).Value = cell.Value
        count = count + 1
    End If
Next cell

End Sub

Answer 2

感謝Ibo的幫助！ 循環遍歷突出顯示的單元格。

對於它的價值，我最終根據在給定行中是否將它們標記為“ x”而更改了復制和粘貼列的方法。 如果它能幫助在這里絆倒的任何人，代碼都在下面。

Sub AutoPopulateX()
Dim SingleCell As Range
Dim ListofCells As Range
Dim i As Integer

'Clear Dashboard
    Worksheets("Dashboard").Activate
    Worksheets("DashBoard").Cells.ClearContents

'Move to In Motion and Set Range
    Worksheets("In Motion").Activate
    Application.Goto Range("a1")

    Set ListofCells = Worksheets("In Motion").Range("a2:ba2").Cells

    i = 1
    Set SingleCell = Worksheets("In Motion").Cells(2, i)

'Loop: search for xyz and copy paste to Dashboard
    For Each SingleCell In ListofCells
        If InStr(1, SingleCell, "x", 1) > 0 Then
                Range(Cells(3, i), Cells(Rows.count, i)).Copy
                Worksheets("Dashboard").Paste Destination:=Worksheets("Dashboard").Cells(1, Columns.count).End(xlToLeft).Offset(0, 1)
        End If
        Application.Goto Range("a1")
        i = i + 1
    Next SingleCell

'Clean up Dashboard
    Worksheets("Dashboard").Columns("a").Delete
    Worksheets("Dashboard").Activate

End Sub