VBA对多列数据相同用红色单元格背景色

laoau138

VBA对多列数据相同用红色单元格背景色

wanao2008

请测试，肯定不是字典法。

1. Sub wanao()
   
2.     Dim arr, k As Integer
   
3.     arr = Range("a1").CurrentRegion
   
4.     For x = UBound(arr) To 3 Step -1
   
5.         For y = 2 To x - 1
   
6.             For i = 1 To 5
   
7.                 If Cells(x, i) = Cells(y, i) Then
   
8.                     k = k + 1
   
9.                 End If
   
10.             Next
    
11.             If k >= 4 Then Range("a" & x & ":e" & x).Interior.ColorIndex = 3
    
12.             k = 0
    
13.         Next
    
14.     Next
    
15. End Sub

复制代码

laoau138

wanao2008 发表于 2016-12-13 17:37
请测试，肯定不是字典法。

另一种方法   用字典如何做

一沫昔阳虹w

没看明白什么意思

laoau138

一沫昔阳虹w 发表于 2016-12-14 07:29
没看明白什么意思

四列内容相同者的每一行，都添加背景红色


所以，第9，第15，第25行，都添加背景红色


用VBA两种方法实现    第一种用数组    第二种用字典

一沫昔阳虹w

laoau138 发表于 2016-12-14 08:13
四列内容相同者的每一行，都添加背景红色

还是没明白，哪里内容相同啊，

grf1973

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

复制代码

grf1973

应该是5列都相同吧。

grf1973

1. Sub ttt()     '数组法
   
2.     [a2:e10000].Interior.ColorIndex = 0
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arr) - 1
   
5.         x = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5)
   
6.         For ii = i + 1 To UBound(arr)
   
7.             xx = arr(ii, 1) & arr(ii, 2) & arr(ii, 3) & arr(ii, 4) & arr(ii, 5)
   
8.             If x = xx Then xstr = xstr & "," & Cells(i, 1).Resize(1, 5).Address(0, 0) & "," & Cells(ii, 1).Resize(1, 5).Address(0, 0)
   
9.         Next
   
10.     Next
    
11.     xstr = Mid(xstr, 2)
    
12.     If Len(xstr) > 0 Then Range(xstr).Interior.ColorIndex = 3
    
13. End Sub
    

复制代码

laoau138

一沫昔阳虹w 发表于 2016-12-14 09:11
还是没明白，哪里内容相同啊，

做这一条啊高手

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