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

陈功

问题：vba 解决找出同一日期中重复名字，并写在d 列对应行中。谢谢大家帮助！

例：

2016/1/1

张三一、李小二、王人和、李六2

2016/1/2

张三3、李小二、王人2、李六

2016/1/10 张三一、李小二、王人和、李六

2016/1/2

陈水五、李小二、王人和、李六

2016/1/20

张三一、李小二、王人和、李六

2016/1/6

张三一、李小二、王人和、李六

2016/1/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 = d(aa)(0) Then
    
29.               ss = ss & "、" & bb
    
30.             End If
    
31.           End If
    
32.         Next
    
33.         d(aa) = Mid(ss, 2)
    
34.       Else
    
35.         d.Remove (aa)
    
36.       End If
    
37.     Next
    
38.     For i = 1 To UBound(arr)
    
39.       If d.exists(arr(i, 2)) Then
    
40.         arr(i, 4) = d(arr(i, 2))
    
41.       End If
    
42.     Next
    
43.     .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

陈功

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

老师，水平高，热心帮助，非常感谢！

chxw68

前面的代码有点小BUG。

陈功

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

老师，我要在日期和人员之间插入一列或多列，我改不对代码。请您标准代码，行吗？
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("e2:e" & r).ClearContents
    arr = .Range("a2:e" & r)
    For i = 1 To UBound(arr)
      If Not d.exists(arr(i, 3)) Then
        Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
      End If
      d(arr(i, 3))(0) = d(arr(i, 3))(0) + 1
      brr = Split(arr(i, 4), "、")
      For j = 0 To UBound(brr)
        If Not d(arr(i, 3)).exists(brr(j)) Then
          Set d(arr(i, 3))(brr(j)) = CreateObject("scripting.dictionary")
        End If
        d(arr(i, 3))(brr(j))(i) = ""
      Next
    Next
    For Each aa In d.keys
      If d(aa)(0) > 1 Then
        ss = ""
        For Each bb In d(aa).keys
          If bb <> 0 Then
            If d(aa)(bb).Count = d(aa)(0) Then
              ss = ss & "、" & bb
            End If
          End If
        Next
        d(aa) = Mid(ss, 2)
      Else
        d.Remove (aa)
      End If
    Next
    For i = 1 To UBound(arr)
      If d.exists(arr(i, 3)) Then
        arr(i, 4) = d(arr(i, 3))
      End If
    Next
    .Range("a2").Resize(UBound(arr), UBound(arr, 3)) = arr
  End With
End Sub
不知哪发错了

chxw68

陈功 发表于 2018-3-17 18:20
老师，我要在日期和人员之间插入一列或多列，我改不对代码。请您标准代码，行吗？
Sub test()
  Dim r% ...

主要是把日期和人员列对应上就行了。

陈功

chxw68 发表于 2018-3-17 18:34
主要是把日期和人员列对应上就行了。

1	2016/1/1	张三一、李小二、王人和、李六2
2	2016/1/2	张三3、李小二、王人2、李六	李小二、李六
3	2016/1/3	张三一、李小二、王人和、李六
4	2016/1/4	张三一、李小二、王人和、李六1
5	2016/1/5	张三一、李小二、王人和、李六
6	2016/1/6	张三一、李小二、王人和、李六	张三一、王人和、李六
7	2016/1/7	张三一、李小二、王人和、李六
8	2016/1/8	同中人、李小二、王人和、李六	王人和
9	2016/1/9	钱七多、李小二、王人和、麻烦
10	2016/1/10	张三一、李小二、王人和、李六
11	2016/1/11	张三一、李小二、王人和、李六
12	2016/1/12	张三一、李小二、王人和、李六
13	2016/1/2	陈水五、李小二、王人和、李六	李小二、李六
14	2016/1/14	张三一、李小二、王人和、李六
15	2016/1/6	张三一、李小、王人和、李六	张三一、王人和、李六
16	2016/1/16	张三一、李小二、王人和、李六
17	2016/1/17	张三一、李小二、王人和、李六
18	2016/1/8	张三一、同中人、王人和、神以人	王人和
19	2016/1/19	张三一、同中人、王人和、神以人
20	2016/1/8	张三一、人、王人和、神以人	王人和
	2016/1/8	张三一、同中人、王人和、神以人
	2016/1/2	陈水五、李小二、王人和、李六

老师，不行了，除了下拉或复制表1至20行的内容，能正常找出重复人员，在21行以后新增手工录入数据时，找不出重复人员。1至20行的内容修改也不行

18	2016/1/8	张三一、同中人、王人和、神以人	王人和
19	2016/1/8	张三一、李小二、王人和、李六	王人和

ww87725244

1. Sub aa()
   
2. Dim arr, i&, k&, ar1, d As Object, m&, n&, d1 As Object, k1&, k2$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     arr = .Range("b2:d" & .UsedRange.Rows.Count)
   
7.       For i = 1 To UBound(arr)
   
8.         If d.exists(arr(i, 1)) Then
   
9.             k = d(arr(i, 1))
   
10.            ar1 = Split(arr(k, 2) & "、" & arr(i, 2), "、")
    
11.             For n = 0 To UBound(ar1)
    
12.                 If d1.exists(ar1(n)) Then
    
13.                     k2 = k2 & ar1(n) & "、"
    
14.                 Else
    
15.                     d1(ar1(n)) = k1
    
16.                 End If
    
17.             Next
    
18.             arr(k, 3) = Left(k2, Len(k2) - 1)
    
19.             arr(i, 3) = Left(k2, Len(k2) - 1)
    
20.             k2 = ""
    
21.             d1.RemoveAll
    
22.         Else
    
23.             m = m + 1
    
24.            d(arr(i, 1)) = m
    
25.         End If
    
26.       Next
    
27. .[b2].Resize(UBound(arr), UBound(arr, 2)) = arr
    
28. End With
    
29. End Sub

复制代码

chxw68

陈功 发表于 2018-3-17 19:43
老师，不行了，除了下拉或复制表1至20行的内容，能正常找出重复人员，在21行以后新增手工录入数据时，找 ...

代码是根据第一列来判断数据有多少行的！你在第1列一定要输上内容。