问题描述
我正在尝试制作一个程序,其中在两个设置的列中有两组数字,例如发送方和接收方编号.我想为值的每个实例分配该数字唯一的颜色.但是,如果发件人号码位于收件人列中,反之亦然,则两列之间的颜色应该相同.
I am trying to make a program in which there are two sets of numbers in two set columns, like sender and receiver numbers. I want to assign each instance of a value a colour that is unique to that number. However if a sender number is in the receiver column and vice versa, the two should have the same colour between the two columns.
到目前为止,我可以在一个专栏中使用它.我尝试过使用列变量:
I have this so far which works within one column. I have tried playing with the column variables:
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
推荐答案
以下Change
事件将使用函数可在C或E列中的其他任何位置(不一定仅在其上方的行中)获取该值的现有颜色.
The following Change
event will set the colour of any new value entered into either column C or E, utilising the FindColour
function to obtain the existing colour for that value anywhere else in column C or E (not necessarily only in rows above it).
ResetThem
子例程清除C和E列上的所有格式,然后从头开始重置颜色. (如果您已经在那些尚未着色的列中有数据,则很有用.)
The ResetThem
subroutine clears out all formatting on columns C and E and then resets the colours starting from scratch. (Useful if you already have data in those columns which hasn't yet been coloured.)
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
一个潜在的问题是,如果在同一列中其下一个单元格中已经存在相同值而另一列中不存在该值时,则将该值输入到单元格中,则将分配新的颜色.有很多方法可以解决该问题,但是我不确定它是否会在您遇到的情况下发生,所以我没有考虑到它.
One potential problem is that, if a value is entered into a cell when that same value already exists in a cell below it in the same column but doesn't exist in the other column, a new colour will be assigned. There are ways around that issue, but I'm not sure whether it will occur in your situation, so I haven't catered for it.
这篇关于为值的每个实例分配颜色的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!