Question

我正在尝试制作一个程序，其中两组数据中有两组数字，例如发送者和接收者号码。我想为值的每个实例分配一个该数字唯一的颜色。但是，如果发件人编号在接收者列中，反之亦然，则两列之间的颜色应该相同。

到目前为止我有这个在一列内工作。我尝试过使用列变量：

Private Sub Worksheet_Change(ByVal target As Range)
Set wf = Application.WorksheetFunctio
If target.Cells.Count = 1 Then
    If target.Column = 3 Then
    x = 0
    On Error Resume Next
    x = wf.Match(target.Value, _
        Range("C1").Resize(target.Row - 1), 0)
    On Error GoTo 0
    If x > 0 Then
        target.Interior.Color = Cells(x, 3).Interior.Color
        Else
            target.Interior.Color = RGB( _
                wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255))
        End If
    End If
End If

If target.Cells.Count = 1 Then
    If target.Column = 5 Then
    x = 0
    On Error Resume Next
    x = wf.Match(target.Value, _
        Range("e1").Resize(target.Row - 1), 0)
    On Error GoTo 0

    If x > 0 Then
        target.Interior.Color = Cells(x, 5).Interior.Color
        Else
            target.Interior.Color = RGB( _
                wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255))
        End If
    End If
End If
End Sub

Answer 1

我认为你只是倒退了。当您在另一列上使用匹配功能时，您正在编辑的同一列上使用匹配功能。您还要调整同一列上的范围大小，该列可能比您的其他列具有更多或更少的行，这可能会限制范围以在相对列上找到完全匹配。

我改变了你的代码，我让它工作。

Private Sub Worksheet_Change(ByVal target As Range)
Set wf = Application.WorksheetFunction
If target.Cells.Count = 1 Then
    If target.Column = 5 Then
    x = 0
    On Error Resume Next
    x = wf.Match(target.Value, _
        Range("C1:C" & [C3000].End(xlUp).Row), 0)
    On Error GoTo 0
    If x > 0 Then
        target.Interior.Color = Cells(x, 3).Interior.Color
        Else
            target.Interior.Color = RGB( _
                wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255))
        End If
    End If
End If

If target.Cells.Count = 1 Then
    If target.Column = 3 Then
    x = 0
    On Error Resume Next
    x = wf.Match(target.Value, _
        Range("E1:E" & [E3000].End(xlUp).Row), 0)
    On Error GoTo 0

    If x > 0 Then
        target.Interior.Color = Cells(x, 5).Interior.Color
        Else
            target.Interior.Color = RGB( _
                wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255))
        End If
    End If
End If

End Sub

我刚刚切换了target.Column =＃和每个循环中的范围引用来查看相反的列。最后要注意的是，使用随机化可以在不同的数字上获得相同的颜色。

Answer 2

以下Change事件将设置输入到列C或E中的任何新值的颜色，并使用FindColour函数获取该值的现有颜色列C或E中的任何其他位置（不一定只在其上方的行中）。

ResetThem子例程清除列C和E上的所有格式，然后从头开始重置颜色。（如果您已经在那些尚未着色的列中拥有数据，则非常有用。）

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Column = 3 Or Target.Column = 5 Then
            Target.Interior.Color = FindColour(Target.Value)
        End If
    End If
End Sub

Function FindColour(v As Variant) As Long
    Set wf = Application.WorksheetFunction
    On Error Resume Next
    x = 0
    'See if value exists in column C
    x = wf.Match(v, Range("C:C"), 0)
    If x > 0 Then
        If Cells(x, "C").Interior.Color <> vbWhite Then
            FindColour = Cells(x, "C").Interior.Color
            Exit Function
        End If
    End If
    'See if value exists in column E
    x = wf.Match(v, Range("E:E"), 0)
    If x > 0 Then
        If Cells(x, "E").Interior.Color <> vbWhite Then
            FindColour = Cells(x, "E").Interior.Color
            Exit Function
        End If
    End If
    'Assign a random colour
    FindColour = RGB(wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255))
End Function

Sub ResetThem()
    With Columns("C").Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Columns("E").Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Dim r As Long
    'Starting at row 2 to avoid assigning a colour to headings
    ' (change "2" to "1", or some other number, as appropriate)
    For r = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        If Not IsEmpty(Cells(r, "C").Value) Then
            Cells(r, "C").Interior.Color = FindColour(Cells(r, "C").Value)
        End If
    Next r
    For r = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        If Not IsEmpty(Cells(r, "E").Value) Then
            Cells(r, "E").Interior.Color = FindColour(Cells(r, "E").Value)
        End If
    Next r
End Sub

一个潜在的问题是，如果在同一列中位于其下方的单元格中已存在相同值但在另一列中不存在的情况下将值输入单元格，则将分配新颜色。有很多方法可以解决这个问题，但我不确定它是否会在你的情况下发生，所以我还没有能够满足它。

为每个值的实例指定颜色

2 个答案: