添加一个去重的功能。添加一个加背景颜色的功能

zxjcn

添加一个去重的功能。添加一个加背景颜色的功能（最好是按钮）

C到Z列是手动输入的数据（1～16），我想在AB到AU显示C到Z的去重数据。
然后在添加一个背景色的按钮。也就是C到Z列与B列的某一行比较一下。如果有一样的数据。就加个背景色。
同样。AB到AU与B列的某一行比较一下。如果有一样的数据。就加个背景色。

统计.rar (1.72 MB, 下载次数: 1)

2018-7-7 23:56 上传

点击文件名下载附件

tudarong

新手小白一枚，
附件追加了去重功能，但排序还没有写好。
如果可以使用，请赠送小花，以资鼓励。
统计1.rar (1.71 MB, 下载次数: 0)

2018-7-8 07:09 上传

点击文件名下载附件

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim m%, Arr, i%, j%
   
4.     Dim rng, rng1 As Range
   
5.     Application.ScreenUpdating = False
   
6.     m = Sheet1.Range("a65536").End(xlUp).Row
   
7.     i = 1
   
8.     For j = 2 To m
   
9.         Set dic = CreateObject("scripting.dictionary")
   
10.         For i = 1 To 24
    
11.             Arr = Sheet1.Range("c" & j & ":z" & j)
    
12.             dic(Arr(1, i)) = ""
    
13.             i = i + 1
    
14.         Next
    
15.         Range("AB" & j).Resize(1, dic.Count) = dic.keys
    
16.         Set dic = Nothing
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

tudarong

追加了添加重复项添加背景色功能。
统计2.rar (1.71 MB, 下载次数: 2)

2018-7-8 07:43 上传

点击文件名下载附件

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim m%, Arr, i%, j%
   
4.     Dim rng, rng1 As Range
   
5.     Application.ScreenUpdating = False
   
6.     m = Sheet1.Range("a65536").End(xlUp).Row
   
7.     i = 1
   
8.     For j = 2 To m
   
9.         Set dic = CreateObject("scripting.dictionary")
   
10.         For i = 1 To 24
    
11.             Arr = Sheet1.Range("c" & j & ":z" & j)
    
12.             If Range("B" & j) = Arr(1, i) Then
    
13.                 Range("B" & j).Offset(0, i).Interior.Color = 15773696
    
14.             End If
    
15.             dic(Arr(1, i)) = ""
    
16.             i = i + 1
    
17.         Next
    
18.         Range("AB" & j).Resize(1, dic.Count) = dic.keys
    
19.         For Each rng In Range("AB" & j).Resize(1, dic.Count)
    
20.             If rng = Range("B" & j) Then
    
21.                 rng.Interior.Color = 15773696
    
22.             End If
    
23.         Next
    
24.         Set dic = Nothing
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

zxjcn

tudarong 发表于 2018-7-8 07:43
追加了添加重复项添加背景色功能。

谢谢。这个是我想要的功能。发现有一个地方有问题。点按钮时。这个去重功能。不对。


请问一下。这个按钮可以移到第一行吗？因为我的首行是固定不动的。数据多了。找这个按钮比较方便。 谢谢

zxjcn

tudarong 发表于 2018-7-8 07:43
追加了添加重复项添加背景色功能。

  这个去重后。显示的不对阿。第一行。很明显应该是5个数字。

zxjcn

tudarong 发表于 2018-7-8 07:43
追加了添加重复项添加背景色功能。

还有这个按钮可以帮我移到第一行吗？放在AV1 哪里。谢谢

tudarong

zxjcn 发表于 2018-7-8 08:31
这个去重后。显示的不对阿。第一行。很明显应该是5个数字。

统计2.rar (1.71 MB, 下载次数: 6)

2018-7-8 13:59 上传

点击文件名下载附件

不好意思，没有检查，多写了一句代码，导致去重错误。
已修正，请测试。
去重后重新排序的功能还没有追加。

tudarong

zxjcn 发表于 2018-7-8 08:39
还有这个按钮可以帮我移到第一行吗？放在AV1 哪里。谢谢

这个按钮你可以自己移动的，鼠标右击选中，然后将按钮拖到你想放的位置就可以了。
按钮的文字也是可以修改的，鼠标右击按钮后有选项。

zxjcn

tudarong 发表于 2018-7-8 14:00
不好意思，没有检查，多写了一句代码，导致去重错误。
已修正，请测试。
去重后重新排序的功能还没有 ...

不用排序了。这就挺好了。够我用了。给我省了不少的事情。谢谢

tudarong

附件已经追加了去重后排序功能，请测试。
楼主要求的去重、排序、重复项添加背景色功能已完成。
20180709_统计（去重排序背景色）.rar (1.71 MB, 下载次数: 6)

2018-7-9 21:35 上传

点击文件名下载附件

1. Sub test()
   
2.     Dim dic As Object
   
3.     Dim m%, Arr, i%, j%, Brr, Crr, p%, a%, k%, temp
   
4.     Dim rng, rng1 As Range
   
5.     Application.ScreenUpdating = False
   
6.     m = Sheet1.Range("a65536").End(xlUp).Row
   
7.     i = 1
   
8.     For j = 2 To m
   
9.     '--------------------------------------------------------------------
   
10.     '去重
    
11.         Set dic = CreateObject("scripting.dictionary")
    
12.         For i = 1 To 24
    
13.             Arr = Sheet1.Range("c" & j & ":z" & j)
    
14.             If Range("B" & j) = Arr(1, i) Then
    
15.                 Range("B" & j).Offset(0, i).Interior.Color = 15773696
    
16.             End If
    
17.             dic(Arr(1, i)) = ""
    
18.         Next
    
19.         Range("AB" & j).Resize(1, dic.Count) = dic.keys
    
20. '        Stop
    
21.     '---------------------------------------------------------------------
    
22.     '从小到大排序
    
23.         Brr = Range("AB" & j).Resize(1, dic.Count)
    
24.         For a = 1 To dic.Count - 2
    
25.             p = a
    
26.             For k = a + 1 To dic.Count - 1
    
27.                 If Brr(1, p) > Brr(1, k) Then
    
28.                     p = k
    
29.                 End If
    
30.             Next
    
31.             If p <> a Then
    
32.                 temp = Brr(1, a)
    
33.                 Brr(1, a) = Brr(1, p)
    
34.                 Brr(1, p) = temp
    
35.             End If
    
36.         Next
    
37. '        Stop
    
38.         Range("AB" & j).Resize(1, dic.Count) = Brr
    
39.     '---------------------------------------------------------------------
    
40.     '重复项添加背景色
    
41.         For Each rng In Range("AB" & j).Resize(1, dic.Count)
    
42.             If rng = Range("B" & j) Then
    
43.                 rng.Interior.Color = 15773696
    
44.             End If
    
45.         Next
    
46.         Set dic = Nothing
    
47.     Next
    
48.     Application.ScreenUpdating = True
    
49. End Sub

复制代码