数据去重合并问题求助

6720918hw

LIUZHU 发表于 2024-5-21 17:10
这个合并去重的方式有问题啊，怎么是隔行合并呢，不是按顺序合并，隔行合并，那不是要通过肉眼来观察啊？

主要原始数据是很多行  并不是按顺序去合并，就是全量的根据重复元素重新组合

6720918hw

cnmlgb9998 发表于 2024-5-21 12:26
PQ方案。。。。。。。。。。。。。。。。。。

大佬 PQ用这个码报错  不知道为啥  还方便发个你成功的压缩包我看下啊   多谢了

cnmlgb9998

报错原因，是因为你 源文件，要重新定义一下，很简单的。

6720918hw

cnmlgb9998 发表于 2024-5-21 18:26
报错原因，是因为你 源文件，要重新定义一下，很简单的。

老哥还方便发下代码啊    照你的图片手打报错  不知道是不是敲错了   多谢了  原文件是这个  一万多行的 不知道执行了行不行

cnmlgb9998

6720918hw 发表于 2024-5-24 15:40
老哥还方便发下代码啊    照你的图片手打报错  不知道是不是敲错了   多谢了  原文件是这个  一万多行的  ...

你这1万多行数据量太大，很卡。我把数据源 削到1000行了。

6720918hw

cnmlgb9998 发表于 2024-5-24 17:01
你这1万多行数据量太大，很卡。我把数据源 削到1000行了。

原始数据没事，可以先用少的测试，

我刚看了跑完的结果，还是有很多重复的，

如下图橙色

但是表后面部分重复的又没了（就是想要这个效果）




最终结果想要的是大组里面互相没有重复，

附件里面保留了999个小组，里面一共1133个不重复的元素，

最后根据互相关系得到的XX个大组，大组里面的元素互相不重乎，

最后大组元素加起来还是1133个

就下面的逻辑  不知道大佬还有办法啊

LJX2008m

留个脚印！继续关注学习！

准提部林

關聯群組// ..by.准提部林
未優化...
Xl0000234.rar (14.26 KB, 下载次数: 4)

2024-5-25 18:49 上传

点击文件名下载附件

6720918hw

准提部林 发表于 2024-5-25 18:50
關聯群組// ..by.准提部林
未優化...

大佬  用原始的一万多条数据替换了下  转圈圈半小时还没结束


然后就报错了

lxdexcel

看一下楼主给出的数据，A列与B列是一样的，不知道实际的数据是否是这样，这与楼主给的示例是不同的的，以下代码适用实际数据，分组后是有些较大的组，水平放置是放不下的，按列放置由于分组数很多，有700多组，也是不行的，一个工作表是不好存放结果的。

1. Option Explicit
   
2. 
   
3. 
   
4. 
   
5. Function findRowID_first(rng As Range, key As Variant, Optional first As Long = 1, Optional last As Long = -1) As Long
   
6.     Dim low&, hight&, cur&
   
7.     low = first
   
8.     hight = last
   
9.    If last = -1 Then hight = rng.Rows.Count + first - 1
   
10.    cur = low
    
11.    Do
    
12.      If rng.Cells(cur, 1) < key Then
    
13.         low = cur
    
14.      Else
    
15.         hight = cur
    
16.      End If
    
17.    
    
18.        cur = low + (hight - low) \ 2
    
19.       
    
20.    Loop While hight - low > 1
    
21.       findRowID_first = IIf(rng.Cells(hight, 1) = key, hight, -1)
    
22.       
    
23. End Function
    
24. 
    
25. 
    
26. Sub getData()
    
27. Dim dt As Object
    
28. Dim ds As Object
    
29. 
    
30. Dim last&, r&, c&, i&
    
31. Dim str$
    
32. Dim ar() As Variant
    
33. Dim u&, v&
    
34. 
    
35. Set dt = CreateObject("Scripting.Dictionary")
    
36. Set ds = CreateObject("Scripting.Dictionary")
    
37. Application.ScreenUpdating = False
    
38. Sheets("s").Cells.ClearContents
    
39. Sheets("s1").Cells.ClearContents
    
40. Sheets("temp").Cells.ClearContents
    
41. Sheets("s").Range("a1") = "number"
    
42.   
    
43. 
    
44. With Sheets("temp")
    
45. Sheets("Sheet2").Range("A1").CurrentRegion.Copy .Range("A1")
    
46. 
    
47.   .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("B2")
    
48.   r = 2
    
49.   c = 2
    
50.     str = .Cells(2, 1)
    
51. Do While Len(str) <> 0
    
52.    
    
53.         dt.RemoveAll
    
54.         ds.RemoveAll
    
55.         dt(str) = ""
    
56.      Do While dt.Count <> 0
    
57.      
    
58.      
    
59.        str = dt.keys()(0)
    
60.       
    
61.        dt.Remove str
    
62.         ds(str) = ""
    
63.         last = .Range("a65536").End(xlUp).Row
    
64.         i = findRowID_first(.Range("a1:a" & last), str, 2, last)
    
65.         
    
66.         If i <> -1 Then
    
67.           Do While 1
    
68.             If .Cells(i, 1) <> str Then Exit Do
    
69.             If Not ds.Exists(.Cells(i, 2).Value) Then dt(.Cells(i, 2).Value) = ""
    
70.             .Rows(i).Delete
    
71.         
    
72.            Loop
    
73.         
    
74.         End If
    
75.      Loop
    
76.      
    
77.      Sheets("s").Range("a" & r) = ds.Count
    
78.      
    
79.      If ds.Count < 30 Then
    
80.        Sheets("s").Range("c" & r).Resize(1, ds.Count) = ds.keys
    
81.      Else
    
82.        Sheets("s1").Cells(1, c) = ds.Count
    
83.        Sheets("s1").Cells(2, c).Resize(ds.Count, 1) = Application.Transpose(ds.keys)
    
84.        c = c + 1
    
85.       
    
86.      End If
    
87.        r = r + 1
    
88.        str = .Cells(2, 1)
    
89. Loop
    
90.          
    
91.       Sheets("s").Range("b1") = r - 2
    
92.          
    
93.   End With
    
94.    
    
95. Application.ScreenUpdating = True
    
96. End Sub
    
97. 
    

复制代码