找出同一日期中重复名字，并写在d 列对应行中

陈功

chxw68 发表于 2018-3-17 20:28

老师，多试几次都不行。A列输入也不行

chxw68

陈功 发表于 2018-3-17 21:17
老师，多试几次都不行。A列输入也不行

没有搞明白，比如下图中的数据，2016/1/8日有3行数据，那么重复数据是指3行中都有的，还是只要2行中有就行了？

陈功

可能我没表达清楚。重复数据是只要同一时间的任意2行中有就是重复数据，能做到？

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, 1).End(xlUp).Row
   
8.     .Range("d2:d" & r).ClearContents
   
9.     arr = .Range("a2:d" & r)
   
10.     For i = 1 To UBound(arr)
    
11.       If Not d.exists(arr(i, 2)) Then
    
12.         Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
13.       End If
    
14.       d(arr(i, 2))(0) = d(arr(i, 2))(0) + 1
    
15.       brr = Split(arr(i, 3), "、")
    
16.       For j = 0 To UBound(brr)
    
17.         If Not d(arr(i, 2)).exists(brr(j)) Then
    
18.           Set d(arr(i, 2))(brr(j)) = CreateObject("scripting.dictionary")
    
19.         End If
    
20.         d(arr(i, 2))(brr(j))(i) = ""
    
21.       Next
    
22.     Next
    
23.     For Each aa In d.keys
    
24.       If d(aa)(0) > 1 Then
    
25.         ss = ""
    
26.         For Each bb In d(aa).keys
    
27.           If bb <> 0 Then
    
28.             If d(aa)(bb).Count = 1 Then
    
29.               d(aa).Remove (bb)
    
30.               If d(aa).Count = 0 Then
    
31.                 d.Remove (aa)
    
32.               End If
    
33.             End If
    
34.           End If
    
35.         Next
    
36.       Else
    
37.         d.Remove (aa)
    
38.       End If
    
39.     Next
    
40.     For i = 1 To UBound(arr)
    
41.       If d.exists(arr(i, 2)) Then
    
42.         brr = Split(arr(i, 3), "、")
    
43.         ss = ""
    
44.         For j = 0 To UBound(brr)
    
45.           If d(arr(i, 2)).exists(brr(j)) Then
    
46.             ss = ss & "、" & brr(j)
    
47.           End If
    
48.         Next
    
49.         arr(i, 4) = Mid(ss, 2)
    
50.       End If
    
51.     Next
    
52.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
53.   End With
    
54. End Sub
    

复制代码

chxw68

看似很简单的一个问题，实际上还是比较麻烦的。

陈功

chxw68 发表于 2018-3-17 21:55
看似很简单的一个问题，实际上还是比较麻烦的。

看似很简单其实很难，老师辛苦了！

lrh8699

chxw68 发表于 2018-3-17 17:49
详见附件。

老师好：可以帮我看一下https://club.excelhome.net/thread-1701716-1-1.html吗？谢谢

kyxfyzg

仅供参考。。。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     arr = .UsedRange.Value
   
7.     For i = 2 To UBound(arr)
   
8.         s = CDate(arr(i, 2))
   
9.         If Not dic.exists(s) Then
   
10.             dic(s) = arr(i, 3)
    
11.         Else
    
12.             dic(s) = dic(s) & "、" & arr(i, 3)
    
13.         End If
    
14.     Next
    
15.     For i = 2 To UBound(arr)
    
16.         s = CDate(arr(i, 2))
    
17.         br = Split(arr(i, 3), "、")
    
18.         x = dic(s)
    
19.         For y = 0 To UBound(br)
    
20.             q = InStr(x, br(y))
    
21.             h = InStrRev(x, br(y))
    
22.             If q > 0 And h > 0 Then
    
23.                 If q <> h Then
    
24.                     t = t & "、" & br(y)
    
25.                 End If
    
26.             End If
    
27.         Next
    
28.     arr(i, 4) = Mid(t, 2)
    
29.     t = ""
    
30.     Next
    
31.     .Range("d1").Resize(UBound(arr), 1) = Application.Index(arr, 0, 4)
    
32. End With
    
33. End Sub

复制代码

Qs18

试试。。。。。。。。