填充颜​​色时将单元格复制到另一个单元格

Question

我想知道这是否可行：

我在列A上有一行数据，当我突出显示（填充）说明A1颜色时，它会自动复制/粘贴到E1吗？ / p>

Answer 1

如果您正在寻找VBA解决方案，这将有效

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static PrevCell As Range
    If Not PrevCell Is Nothing Then
        If PrevCell.Column = 1 Then
           If PrevCell.Interior.ColorIndex <> xlNone Then
              PrevCell.Copy
              Paste Cells(PrevCell.Row, "E")
           Else
              'In case you unhighlight the cell
              Cells(PrevCell.Row, "E") = ""
              Cells(PrevCell.Row, "E").Interior.ColorIndex = xlNone
           End IF
        End If
    End If
    Application.CutCopyMode = False
    Set PrevCell = Target
End Sub

这里的假设是所有单元格都使用xlNone的标准填充，这意味着没有填充。如果您的单元格具有其他填充颜色，并且您只想在单元格为特定颜色时捕获，则需要将其更改为

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static PrevCell As Range
    If Not PrevCell Is Nothing Then
        If PrevCell.Column = 1 Then
           If PrevCell.Interior.ColorIndex = INSERT PROPER HIGHLIGHTING COLOR INDEX HERE Then
             PrevCell.Copy
             Paste Cells(PrevCell.Row, "E")
           Else
              'In case you unhighlight the cell
              Cells(PrevCell.Row, "E") = ""
              Cells(PrevCell.Row, "E").Interior.ColorIndex = xlNone
           End IF
        End If
    End If
    Application.CutCopyMode = False
    Set PrevCell = Target
End Sub

<强>更新

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static PrevCell As Range
    Dim LastRow As Integer
    Dim lcell As Range
    If Not PrevCell Is Nothing Then
        LastRow = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
        If PrevCell.Column = 1 Then
            If PrevCell.Interior.ColorIndex <> xlNone Then
                PrevCell.Copy
                If Cells(LastRow, "E") <> "" Then
                    Paste Cells(LastRow + 1, "E")
                Else
                    Paste Cells(LastRow, "E")
                End If
            Else
                'In case you unhighlight the cell
                For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
                    If lcell.Value = PrevCell.Value Then
                        lcell.Delete xlShiftUp
                        Exit For
                    End If
                Next lcell
            End If
        End If
    End If
    Application.CutCopyMode = False
    Set PrevCell = Target
End Sub

问题：每次输入突出显示的单元格时，它都会将值附加到列表中。如果在A列中有重复值，则不突出显示1将从E中的运行列表中仅删除1.如果A列中没有重复项，则需要在E上建立循环以确定该值是否已存在。像这样：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Static PrevCell As Range
    Dim LastRow As Integer
    Dim lcell As Range
    Dim isDuplicate AS Boolean

    If Not PrevCell Is Nothing Then
        LastRow = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
        If PrevCell.Column = 1 Then
            If PrevCell.Interior.ColorIndex <> xlNone Then
                For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
                    If lcell.Value = PrevCell.Value Then
                        isDuplicate = True
                        Exit For
                    End If
                Next lcell
                If Not isDuplicate Then
                    PrevCell.Copy
                    If Cells(LastRow, "E") <> "" Then
                        Paste Cells(LastRow + 1, "E")
                    Else
                        Paste Cells(LastRow, "E")
                    End If
                End If
            Else
                'In case you unhighlight the cell
                For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
                    If lcell.Value = PrevCell.Value Then
                        lcell.Delete xlShiftUp
                    End If
                Next lcell
            End If
        End If
    End If
    Application.CutCopyMode = False
    Set PrevCell = Target
End Sub