跨表查重

simic1989

求个跨表查重宏
假设有无穷个表。
求个跨表查重的宏，将重复的名字登记在表1，然后标出出现在哪张表

jiminyanyan

http://club.excelhome.net/thread-868892-1-1.html
例2.....

simic1989

jiminyanyan 发表于 2017-4-25 20:39
http://club.excelhome.net/thread-868892-1-1.html
例2.....

谢谢指引，我先学习一下

lr116529111

  拿去不谢，，，

simic1989

Sub cfz()
Dim i&, Myr&, Arr
Dim d, k, t
Set d = CreateObject("Scripting.Dictionary")
Myr = Sheet1.[a65536].End(xlUp).Row
Arr = Sheet1.Range("a1:g" & Myr)
For i = 2 To UBound(Arr)
    d(Arr(i, 3)) = d(Arr(i, 3)) + 1
Next
k = d.keys
t = d.items
Sheet2.Activate
[a2].Resize(d.Count, 1) = Application.Transpose(k)
[b2].Resize(d.Count, 1) = Application.Transpose(t)
[a1].Resize(1, 2) = Array("姓名", "重复个数")
Set d = Nothing
End Sub
这是一个单表格查重的宏，请问需要做哪些修改可以改成多表查重吗？

simic1989

lr116529111 发表于 2017-4-25 20:50
拿去不谢，，，

您好，这个第一次出现重复的表不显示表名，能麻烦改一下吗

jjmysjg

文件夹内的独立表能实现吗

凌空一羽

1. Sub 凌空一羽()
   
2. Dim sht As Worksheet
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For Each sht In Worksheets
   
5.     If sht.Name <> "Sheet1" Then
   
6.         ar = sht.Range("b6:c27")
   
7.         For i = 1 To UBound(ar)
   
8.         s = ar(i, 1)
   
9.             If Not d.exists(s) Then
   
10.                 d(s) = Array(s, 1, IIf(ar(i, 1) <> "", sht.Name, ""))
    
11.             Else
    
12.                 k = d(s): k(1) = k(1) + 1: k(2) = k(2) & "," & IIf(ar(i, 1) <> "", sht.Name, "")
    
13.                 d(s) = k
    
14.             End If
    
15.         Next
    
16.     End If
    
17. Next
    
18. ReDim brr(1 To d.Count, 1 To 2)
    
19. For i = 1 To d.Count
    
20.     If Application.Index(Application.Transpose(d.items), 1)(i) <> "" And Application.Index(Application.Transpose(d.items), 2)(i) > 1 Then
    
21.         n = n + 1
    
22.         brr(n, 1) = Application.Index(Application.Transpose(d.items), 1)(i)
    
23.         brr(n, 2) = Application.Index(Application.Transpose(d.items), 3)(i)
    
24.     End If
    
25. Next
    
26. [a2].Resize(n, 2) = brr
    
27. End Sub

复制代码

lr116529111

simic1989 发表于 2017-4-25 21:03
您好，这个第一次出现重复的表不显示表名，能麻烦改一下吗

1. Sub 重复()
   
2. Dim i, j, x, sh, arr(1 To 10000, 1 To 2)
   
3. x = 1
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For Each sh In Worksheets
   
6.     If sh.Name <> "Sheet1" Then
   
7.        i = sh.Cells(Rows.Count, 2).End(xlUp).Row
   
8.            For j = 6 To i
   
9.                a = sh.Cells(j, 2)
   
10.                If d.exists(sh.Cells(j, 2).Value) Then
    
11.                   d(sh.Cells(j, 2).Value) = d(sh.Cells(j, 2).Value) & "," & sh.Name
    
12.                   arr(x, 1) = sh.Cells(j, 2).Value
    
13.                   arr(x, 2) = d(sh.Cells(j, 2).Value)
    
14.                   x = x + 1
    
15.                Else
    
16.                   d(sh.Cells(j, 2).Value) = sh.Name
    
17.                End If
    
18.             Next
    
19.     End If
    
20. Next
    
21. Sheet1.Range("a2").Resize(x - 1, 2) = arr
    
22. End Sub
    

复制代码