查找重复，将结果放在指定工作表中，谢谢！

ztd123

ykcbf1100 发表于 2023-6-29 09:19
附件供参考。。。

再次麻烦您，表里面有说明，真不好意思！ 查重2.zip (36.06 KB, 下载次数: 5)

2024-1-30 13:48 上传

点击文件名下载附件

ykcbf1100

ztd123 发表于 2024-1-30 08:37
再次麻烦您，表里面有说明，真不好意思！

我觉得你这个查重不太合理，应该从分表的查重才对啊。你现在这样，主表中已有数据，与分表查重。如果与分表有重复，那是没事的，问题是当主表中有数据分表中没有的、且分表中也不重复的，主表中的这个数据要清除吗？如果清除了，那下次再运行代码时，就少了这个数据了。
代码写了大半天写不下去了。

ztd123

ykcbf1100 发表于 2024-1-30 11:43
我觉得你这个查重不太合理，应该从分表的查重才对啊。你现在这样，主表中已有数据，与分表查重。如果与 ...

非常感谢您，可能我没表达清楚，再次感谢！祝您快快每一天！

ykcbf1100

ztd123 发表于 2024-1-30 11:49
非常感谢您，可能我没表达清楚，再次感谢！祝您快快每一天！

主表和分表只要是重复的就在主表中出现。

excelkill

暂时用不上，回个帖留存

ztd123

ykcbf1100 发表于 2024-1-30 11:55
主表和分表只要是重复的就在主表中出现。

老师您好，11楼更新了，我描述有问题，您有空再看一下可以吗！谢谢您！

ykcbf1100

ztd123 发表于 2024-1-30 08:37
再次麻烦您，表里面有说明，真不好意思！

参与一下。。。

1. Sub ykcbf2()   '//2024.1.30
   
2.     Dim ar, br, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set d2 = CreateObject("Scripting.Dictionary")
   
6.     Set sh = Sheets("模拟重复结果")
   
7.     With Sheets("主表")
   
8.         fn = .[a1]
   
9.         fn1 = .Name
   
10.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
11.         ar = .[a1].Range("a1:z" & r)
    
12.     End With
    
13.     For i = 2 To UBound(ar)
    
14.         s = ar(i, 4)
    
15.         d(s) = d(s) + 1
    
16.         If Not d1.exists(s) Then
    
17.             d1(s) = Array(fn1, ar(i, 2), ar(i, 3), s, ar(i, 13), ar(i, 15), ar(i, 26))
    
18.         End If
    
19.     Next
    
20.     With Sheets(fn)
    
21.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
22.         br = .[a1].Range("a1:z" & r)
    
23.     End With
    
24.     For i = 2 To UBound(br)
    
25.         s = br(i, 4)
    
26.         d(s) = d(s) + 1
    
27.         If Not d2.exists(s) Then
    
28.             d2(s) = Array(fn, br(i, 2), br(i, 3), s, br(i, 13), br(i, 15), br(i, 26))
    
29.         End If
    
30.     Next
    
31.     On Error Resume Next
    
32.     ReDim brr(1 To 1000, 1 To 8)
    
33.     For Each k In d.keys
    
34.         t1 = d1(k): t2 = d2(k)
    
35.         If d(k) > 1 Then
    
36.             If t2 <> Empty Then
    
37.                 If t1 <> Empty Then
    
38.                     m = m + 1
    
39.                     brr(m, 1) = m
    
40.                     For x = 0 To UBound(t1)
    
41.                         brr(m, x + 2) = t1(x)
    
42.                     Next
    
43.                     m = m + 1
    
44.                     brr(m, 1) = m
    
45.                     For x = 0 To UBound(t2)
    
46.                         brr(m, x + 2) = t2(x)
    
47.                     Next
    
48.                 Else
    
49.                     m = m + 1
    
50.                     brr(m, 1) = m
    
51.                     For x = 0 To UBound(t2)
    
52.                         brr(m, x + 2) = t2(x)
    
53.                     Next
    
54.                 End If
    
55.             End If
    
56.         End If
    
57.     Next
    
58.     With sh
    
59.         .UsedRange.Offset(1).Clear
    
60.         With .[a2].Resize(m, 8)
    
61.             .Value = brr
    
62.             .Borders.LineStyle = 1
    
63.             .HorizontalAlignment = xlCenter
    
64.             .VerticalAlignment = xlCenter
    
65.         End With
    
66.     End With
    
67.     MsgBox "OK！"
    
68. End Sub
    

复制代码

ykcbf1100

ztd123 发表于 2024-1-30 13:51
老师您好，11楼更新了，我描述有问题，您有空再看一下可以吗！谢谢您！

附件供参考。。。

ztd123

ykcbf1100 发表于 2024-1-30 15:07
附件供参考。。。

太感谢了，麻烦您多次，真诚的感谢您，提前祝您春节愉快！