值的每个实例都得到相同的颜色和新的价值观得到了新的色彩

Question

您好我最近问的问题，在这里： Assigning Colours to each Instance of a value， 然而，这结束了工作不适合我，我不确定我是否应该在继续该线程或开始一个新的，因为我已经改变了一些东西。这里是我的新代码，它交替选择两列之间的单元格并更改所选单元格的颜色，但是如果数字已经存在，我希望它们具有相同的颜色。我现在拥有的东西似乎并不匹配，并且尽管存在匹配，仍会指定随机颜色。

Sub colourNumbers() 
Dim a As Long 
Dim b As Long 
Set wf = Application.WorksheetFunction 
Dim analysisSheet As Worksheet 
Set analysisSheet = ActiveSheet 
    lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 

For a = 3 To lastRow 

    If b = 3 Then 
    b = 5 
     Else 
      b = 3 
    End If 

    If b = 5 Then 
     a = a - 1 
    End If 

analysisSheet.Cells(a, b).Select 
With Selection 
x = 0 
On Error Resume Next 
x = wf.Match(Selection.Value, _ 
    Range("C3:E" & [C3000].End(xlUp).Row), 0) 
On Error GoTo 0 
If x > 0 Then 
    target.Interior.Color = Cells(x, 3).Interior.Color 
    Else 
     Selection.Interior.Color = RGB(_ 
      wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255)) 
    End If 
End With 
Next a 
End Sub 

任何帮助，将不胜感激！

Answer 1

假设： - 由于您只改变col C和E的颜色，所以我猜测您只是想在C和E中搜索数字的存在......所以Col D在这里没有任何意义。 ..

Option Explicit 

Sub colourNumbers() 

Dim a, x, x1, x2, b, lastRow, lastCol As Long 
Dim wf As WorksheetFunction 
Dim analysisSheet As Worksheet 
Dim rng1, rng2 As Range 

Set wf = Application.WorksheetFunction 
Set analysisSheet = ThisWorkbook.Worksheets("Sheet1") 


lastRow = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row 


Set rng1 = analysisSheet.Range("C3:C" & lastRow) 
Set rng2 = analysisSheet.Range("E3:E" & lastRow) 

lastCol = 3 

For a = 3 To lastRow 

    If b = 3 Then 
     b = 5 
    Else 
     b = 3 
    End If 

    If b = 5 Then 
     a = a - 1 
    End If 




x = 0 
x1 = 0 
x2 = 0 

On Error Resume Next 
x1 = wf.Match(analysisSheet.Cells(a, b).Value, rng1, 0) + 2 ' match function offset from where the array starts 
On Error GoTo 0 

On Error Resume Next 
x2 = wf.Match(analysisSheet.Cells(a, b).Value, rng2, 0) + 2 
On Error GoTo 0 


If x1 = 0 And x2 > 0 Then 
    x = x2 
ElseIf x2 = 0 And x1 > 0 Then 
    x = x1 
ElseIf x2 > 0 And x1 > 0 Then 
    x = x1 'pick anyone 
Else 
    x = 0 
End If 


'Debug.Print x 
'Debug.Print analysisSheet.Cells(a, b).Value 



If x > 0 And x <> a And b = lastCol Then 
    'Debug.Print "Same" 
    analysisSheet.Cells(a, b).Interior.Color = analysisSheet.Cells(x, 3).Interior.Color 
    lastCol = b 

ElseIf x > 0 And x = a And b <> lastCol Then 
    ' Debug.Print "Same2" 
    analysisSheet.Cells(a, b).Interior.Color = analysisSheet.Cells(x, 3).Interior.Color 

ElseIf x > 0 And x <> a And b <> lastCol Then 
    'Debug.Print "Same2" 
    analysisSheet.Cells(a, b).Interior.Color = analysisSheet.Cells(x, 3).Interior.Color 

Else 
    analysisSheet.Cells(a, b).Interior.Color = RGB(wf.RandBetween(125, 255), wf.RandBetween(125, 255), wf.RandBetween(125, 255)) 

End If 



Next a 



End Sub 

PS：效率，同时也寻找在多个山坳使用找到一把钥匙（）方法，而不是匹配（）。