将单元格颜色复制到另一列

• 从事件代码中，可以使用简单的

CopyColors Me

其中Me是对代码背后的工作表的引用。

• 您需要考虑如何使用它。在每个选择中使用它没有意义。也许可以将它限制在单个单元格中，例如B1：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.CountLarge > 0 Then Exit Sub
    If Intersect(Target, Me.Range("B1")) Is Nothing Then Exit Sub
    ' Now call it:
    CopyColors Me
End If

法典

Sub CopyColors(ByVal ws As Worksheet)
    
    Const SRC_RANGE As String = "A1:A600"
    Const DST_COLUMN As String = "C"
    
    Dim srg As Range: Set srg = ws.Range(SRC_RANGE)
    Dim cOffset As Long: cOffset = ws.Columns(DST_COLUMN).Column - srg.Column
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim sCell As Range, sColor As Long
    
    For Each sCell In srg.Cells
        sColor = sCell.Interior.Color
        If dict.Exists(sColor) Then
            Set dict(sColor) = Union(dict(sColor), sCell)
        Else
            Set dict(sColor) = sCell
        End If
    Next sCell
    
    Dim Key
    
    For Each Key In dict.Keys
        dict(Key).Offset(, cOffset).Interior.Color = Key
    Next Key

End Sub

我不知道您要做什么...但此代码与“目标”无关，可能是事件调用的单独“子”

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim c As Long, rowYouWant As Long, r As Range
    rowYouWant = 20
    Application.ScreenUpdating = False
    Set r = Range("A1") 'starting cell
    With r
        For c = 0 To rowYouWant
            .Offset(c, 2).Interior.Color = .Offset(c, 0).Interior.Color
        Next
    End With
End Sub

'-———————————————————————————————————————————————————————-

Option Explicit

Const SOURSE_RANGE = "C1:C600"
Const FIRST_CELL_OF_MAP = "A1"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim sourseRange As String
    If Not Intersect(Target, Range(SOURSE_RANGE)) Is Nothing Then
        Call copyIntColor
    End If
End Sub

Private Sub copyIntColor()
    Dim cr As Long, cc As Long, colCnt As Long, rowCnt As Long, r As Range, sr As Range
    
    Set sr = Range(SOURSE_RANGE) 'range of table
    colCnt = sr.Columns.CountLarge - 1
    rowCnt = sr.Rows.CountLarge - 1
    Set sr = sr.Cells(1, 1)
    Set r = Range(FIRST_CELL_OF_MAP) 'starting cell of map
    Application.ScreenUpdating = False
    With r
        For cr = 0 To rowCnt
            For cc = 0 To colCnt
                r.Offset(cr, cc).Interior.Color = sr.Offset(cr, cc).Interior.Color
            Next
        Next
    End With
End Sub

我想指出的是，最好在单击按钮时运行代码，而不是在每个“Worksheet_SelectionChange”事件上运行代码