VBA宏从选定的行创建一个新表，首先控制上面另一个单元格的颜色

Question

我是 VBA 宏主题的新手，我正在尝试生成一个新表并形成另一个表，该信息将在两个条件下使用:

如果单元格中的信息处于事件状态(marc)，则该行已被选为图片中的标记 No 1

如果标题中的单元格颜色为绿色，则在第 6 行

所以在检查了这两个点之后，它会获取 2 个单元格的信息并将其放入一个新表中，并一直这样做，直到第 6 行中的最后一个带有绿色背景的单元格。

第二张图是成品

这是我到目前为止的托盘:

Sub SelectColoredCells()
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range
    Dim rRow As Range
    Dim rColumn As Range
    lColor = RGB(0, 176, 80)
    Set rColored = Nothing
    Set rRow = Range("$6:$6")

    For Each rCell In ActiveCell.Row
        If rCell.Interior.Color = lColor Then
                For Each rColumn In Selection
                   If rColumn.Value <> "" Then
                       MsgBox rColumn.Address
                     If rColumn.Value = "" Then
                            Exit For
                        If Sheet1.Cells(6, rColumn).Interior.Color = lColor Then
                         Sheet3.Cells(rRow, rColumn).Value = 
                         Sheet1.Cells(aRow,rColumn).Value
                        End If
                      End If
                    End If
                Next
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
        MsgBox "Selected cells match the color:" & _
            vbCrLf & rColored.Address
    Set rCell = Nothing
    Set rColored = Nothing
End Sub

那么如何让它查找带有事件行标题的单元格呢？

Answer 1

我建议将所有彩色标题统一到一个范围 MarkedHeaders然后使用 Offset()移动到当前选定的行。

这是一个例子:

Option Explicit

Public Sub SelectColoredCellsAndCopy()
    Dim SelectedRow As Long
    SelectedRow = Selection.Row 'remember seleted row

    Const HeaderRow As Long = 6 'define row that contains headers

    Dim LastHeaderColumn As Long
    LastHeaderColumn = Cells(HeaderRow, Columns.Count).End(xlToLeft).Column 'get last used column in header

    Dim MarkedHeaders As Range

    Dim iCol As Long
    For iCol = 1 To LastHeaderColumn 'run from 1 column to last column in header row
        If Cells(HeaderRow, iCol).Interior.Color = RGB(0, 176, 80) Then
            'check color and unify all colored cells into MarkedHeaders
            If MarkedHeaders Is Nothing Then
                Set MarkedHeaders = Cells(HeaderRow, iCol)
            Else
                Set MarkedHeaders = Union(MarkedHeaders, Cells(HeaderRow, iCol))
            End If
        End If
    Next iCol

    'now all colored headers are unified in MarkedHeaders
    'and we can move this selection to the previously selected row

    Dim SelectedRowColoredTitles As Range
    Set SelectedRowColoredTitles = MarkedHeaders.Offset(RowOffset:=SelectedRow - HeaderRow)
    'use offset to move 'selection' from the headers to the previosly selected row

    SelectedRowColoredTitles.Select 'just to show whats inside SelectedRowColoredTitles now
End Sub

然后你可以使用

MarkedHeaders.Copy Destination:=Sheet3.Cells(HeaderRow, 1) 'copy headers
SelectedRowColoredTitles.Copy Destination:=Sheet3.Cells(SelectedRow, 1) 'copy row

将标题或选定的行复制到另一个工作表中。