VBA改写两种方法 多列内容者添加背景色

laoau138

VBA改写两种方法    多列内容者添加背景色

大灰狼1976

附件是不是放错了，还是原来那一个，还是你有其他要求没有说明清楚？

laoau138

大灰狼1976 发表于 2017-6-16 15:37
附件是不是放错了，还是原来那一个，还是你有其他要求没有说明清楚？

现在没有放错

大灰狼1976

先给出数组的解答

1. Sub aaa()
   
2. Dim arr, i&, j&, k&, cl&, rng As Range
   
3. arr = [a1].CurrentRegion
   
4. cl = UBound(arr, 2)
   
5. For i = 2 To UBound(arr) - 1
   
6.   For k = i + 1 To UBound(arr)
   
7.     For j = 1 To cl
   
8.       If j <> 3 Then If arr(i, j) <> arr(k, j) Then Exit For
   
9.     Next j
   
10.     If j = cl + 1 Then
    
11.       If rng Is Nothing Then Set rng = Cells(i, 1).Resize(, 5) Else Set rng = Union(rng, Cells(i, 1).Resize(, 5))
    
12.       Set rng = Union(rng, Cells(k, 1).Resize(, 5))
    
13.     End If
    
14.   Next k
    
15. Next i
    
16. rng.Interior.Color = vbRed
    
17. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-6-16 17:04
先给出数组的解答

这个代码写得好，还要慢慢消化

大灰狼1976

字典。
跟你的结果不一样，可能没有完全理解你的意思吧。

1. Sub bbb()
   
2. Dim arr, i&, j&, d As Object, rng As Range, s$, c
   
3. arr = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 2 To UBound(arr)
   
6.   For j = 1 To UBound(arr, 2)
   
7.     If j <> 3 Then s = s & "," & arr(i, j)
   
8.   Next j
   
9.   If d.exists(s) Then
   
10.     If rng Is Nothing Then Set rng = Cells(d(s), 1).Resize(, 5) Else Set rng = Union(rng, Cells(d(s), 1).Resize(, 5))
    
11.     Set rng = Union(rng, Cells(i, 1).Resize(, 5))
    
12.   Else
    
13.     d(s) = i
    
14.   End If
    
15.   s = ""
    
16. Next i
    
17. rng.Interior.Color = vbRed
    
18. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-6-16 17:04
先给出数组的解答

VBA用数组和字典   计算B列上班天数

http://www.excelpx.com/thread-431224-1-1.html

laoau138

大灰狼1976 发表于 2017-6-16 17:21
字典。
跟你的结果不一样，可能没有完全理解你的意思吧。

其实这个来自Excel VBA程序开发自学宝典(第3版)          理不理解也没有办法了

laoau138

大灰狼1976 发表于 2017-6-16 17:21
字典。
跟你的结果不一样，可能没有完全理解你的意思吧。

只有一个可能，书本答案本来就错了


Sub tt()     '字典法
    [a2:e10000].Interior.ColorIndex = 0
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        x = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5)
        d(x) = d(x) & "," & Cells(i, 1).Resize(1, 5).Address(0, 0)
    Next
    For Each x In d.keys
        xstr = Mid(d(x), 2)
        If InStr(xstr, ",") > 0 Then Range(xstr).Interior.ColorIndex = 3
    Next
End Sub