标出重复且对另一列着色

wowo000

劳烦论坛里的老师：帮俺斧正附件里代码使其符合第二列的效果，谢谢！

ykcbf1100

重复你指的是第几列呢？你的代码写着可是第一列的。

wowo000

ykcbf1100 发表于 2024-3-20 18:26
重复你指的是第几列呢？你的代码写着可是第一列的。

您好！草爷老师：凡是重复的第一个所对应C列的那个单元格不着色，其他都着色（如B列效果），劳烦斧正，多谢！

wowo000

哦，抱歉！尊敬的ykcbf1100老师：是判断第五列（即E列）的重复值。

gwjkkkkk

重复标色，看了一下模拟结果没有看出来怎么逻辑？

wowo000

gwjkkkkk 发表于 2024-3-20 18:37
重复标色，看了一下模拟结果没有看出来怎么逻辑？

尊敬的gwjkkkkk老师：是判断第五列（即E列）的重复值，然后对C列着色

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.         .Range("c5:c" & r).Interior.ColorIndex = 0
   
9.         arr = .Range("a5:h" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             If Not d.exists(arr(i, 5)) Then
    
12.                 d(arr(i, 5)) = i
    
13.             Else
    
14.                 .Cells(4 + i, 3).Interior.ColorIndex = 6
    
15.             End If
    
16.         Next
    
17.     End With
    
18. End Sub
    

复制代码

chxw68

非常简单的问题。

ykcbf1100

我还是喜欢新写一个，要看懂并改好你的代码需要花费更多的时间。
列号输入，２或３都行。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.20
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     lie = Val(InputBox("请输入你要格式化的列号" & Chr(10) & Chr(10) & "比如: 1，2，3等", "温馨提示"))
   
5.     If lie = 0 Then MsgBox "没有输入列号！": Exit Sub
   
6.     r = Cells(Rows.Count, 5).End(3).Row
   
7.     arr = Range("a1:h" & r)
   
8.     ActiveSheet.UsedRange.Offset(4).Interior.ColorIndex = 0
   
9.     For i = 5 To UBound(arr)
   
10.         s = arr(i, 5)
    
11.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.         d(s)(i) = i
    
13.     Next
    
14.     For Each k In d.keys
    
15.         m = 0
    
16.         For i = 5 To UBound(arr)
    
17.             If arr(i, 5) = k Then
    
18.                 For Each kk In d(k).keys
    
19.                     m = m + 1
    
20.                     If m > 1 Then
    
21.                         Cells(kk, lie).Interior.ColorIndex = 6
    
22.                     End If
    
23.                 Next
    
24.                 Exit For
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    

复制代码