任意输入符合要求的填充颜色

liulang0808

局部修改，供参考。。。。、。。

mote66

liulang0808 发表于 2018-7-2 16:52
局部修改，供参考。。。。、。。

你好，当输入有2列数字时，有部分数据没填充颜色。

liulang0808

mote66 发表于 2018-7-2 20:24
你好，当输入有2列数字时，有部分数据没填充颜色。

是没有啊，除了之前的各位
其他必须满足完全相等的

liulang0808

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Set Rng = Application.Intersect([c16:f40], Target)
   
3.     If Not Rng Is Nothing Then
   
4.         Application.ScreenUpdating = False
   
5.         Set d = CreateObject("scripting.dictionary")
   
6.         Range("H16:Z31").Interior.ColorIndex = 0
   
7.         arr = [c16:f40].Value
   
8.         str1 = ""
   
9.         For j = 1 To 4
   
10.             If WorksheetFunction.CountA(Cells(16, j + 2).Resize(25)) = 0 Then
    
11.                 arr(1, j) = 0
    
12.             End If
    
13.         Next j
    
14.         For j = 1 To UBound(arr)
    
15.             If Len(arr(j, 1)) > 0 Then
    
16.                 For i = 1 To UBound(arr)
    
17.                     If Len(arr(i, 2)) > 0 Then
    
18.                         For m = 1 To UBound(arr)
    
19.                             If Len(arr(m, 3)) > 0 Then
    
20.                                 For n = 1 To UBound(arr)
    
21.                                     If Len(arr(n, 4)) > 0 Then
    
22.                                         d(Val(arr(j, 1) & arr(i, 2) & arr(m, 3) & arr(n, 4))) = ""
    
23.                                     End If
    
24.                                 Next n
    
25.                             End If
    
26.                         Next m
    
27.                     End If
    
28.                 Next i
    
29.             End If
    
30.         Next j
    
31.         Set Rng = Nothing
    
32.         If d.Count > 0 Then
    
33.             l = Len(d.keys()(0))
    
34.             arr = Range("H16:Z31")
    
35.             For j = 1 To UBound(arr)
    
36.                 For i = 1 To UBound(arr, 2)
    
37.                     If Len(arr(j, i)) >= l Then
    
38.                         If d.exists(Val(Right(arr(j, i), l))) Then
    
39.                             If Rng Is Nothing Then
    
40.                                 Set Rng = Cells(15 + j, i + 7)
    
41.                             Else
    
42.                                 Set Rng = Union(Rng, Cells(15 + j, i + 7))
    
43.                             End If
    
44.                         End If
    
45.                     End If
    
46.                 Next i
    
47.             Next j
    
48. 
    
49.         End If
    
50.         If Not Rng Is Nothing Then Rng.Interior.ColorIndex = 3
    
51.         Application.ScreenUpdating = True
    
52.     End If
    
53. End Sub
    

复制代码

liulang0808

附件内容供参考，

mote66

liulang0808 发表于 2018-7-2 13:43

版主你好。这个代码也可以提速么。