Question

我想搜索工作表第2行＆＃34; In Motion＆＃34;中的单元格。如果单元格突出显示为黄色，我想复制整个列并将其粘贴到工作表＆＃34;仪表板＆＃34;。我想重复一遍，找到＆＃34; In Motion＆＃34;的第2行中的每个黄色单元格。我还希望将列顺序粘贴到＆＃34; Dashboard＆＃34;。

我所拥有的代码，部分来自运行宏而无法正常工作。它会复制它找到的第一个黄色单元格的列＆＃34; In Motion＆＃34;并粘贴到＆＃34; Dashboard＆＃34;的A1。但是，它不会遍历第2行中的所有单元格。它只是停止。

另外，我认为如果循环工作正常，我的代码就不能有效地将列顺序粘贴到＆＃34; Dashboard＆＃34;。我认为他们都会粘贴到A1。

对不起noob quesiton。非常感谢帮助！

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

将Sheet1的第2行中的黄色单元格顺序复制到Sheet2

2 个答案: