查找重复行并合并值

shixyi37

我的要求是查找A列第3行以下的行（行数不确定）是否有重复名称，如果有，那么将相同名称所对应的C列到Q列的数值对应求和到第一次出现的行，然后删除后面出现的重复行。网上也有查找重复并合并值后删除重复行的代码，但我的数据量很大（5万多6万行），运行一次需要起码10分钟，现在想找一个运行高效的代码。在百度文库中找到以下这样一个查找重复行并合并值的代码，运行时提示用户定义类型未定义，是不是因为其定义：yy、mk、ya、mb、mt与句子内容:yy、mk、mb、xx、xc、mu前后不一致？不知道怎么改才对得上，求教大师。谢谢！
sub button2_click()
dim yy As lnteger
Dim mk,ya,mb,mt
For yy = worksheets("ABCD").Range("i66564").End(xlUp).Row To 1 Step -1 '获取sheet名ABCD的i列有多少有效傎，从最后一个有效值开始递减1列
mk = Application.WorksheetFunction.Countif(Worksheets("ABCD").Range("i1:i" & yy), Worksheets("ABCD").Range("i" & yy)) '使用countif根据一个有效值与i列比较，有多少相同数量的有效值。
if mk > 1 Then '如果mk大于1，表示i列至少有一个重复
   mb = Worksheets("ABCD").Range("i" & yy)  '获取i列值
   On Error Resume Next '出错继续
   xx = WorksheetFunction.Match(mb,Worksheets("ABCD").Range("i1:i" & yy),0) '获取i列中这个有效值第一次出现的位置
   xc = Worksheets("ABCD").Range("j" & xx)  '取出根据第一次出现位置号偏移位置的数值
   mu = Worksheets("ABCD").Range("j" & yy)   '取出根据递减位置号偏移位置的数值。
Worksheets("ABCD").Range("j" & xx).Value = xc + mu   '将最后一个值与第一次出现的值合并。
Worksheets("ABCD").Range("i" & yy).EntireRow.Delete  '删除重复的最后一个数值行。

End if
Next
End Sub


查找重复并合并值后删除.zip (27.3 KB, 下载次数: 11)

2015-3-16 15:08 上传

点击文件名下载附件

grf1973

最好上个附件。

1. Sub button2_click()
   
2.     Dim yy As lnteger, r, arr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     With Worksheets("ABCD")
   
6.         r = .Range("i66564").End(xlUp).Row
   
7.         arr = .Range("i1:j" & r)
   
8.         For yy = 1 To r
   
9.             d(arr(yy, 1)) = d(arr(yy, 1)) + arr(yy, 2)
   
10.             d1(arr(yy, 1)) = d1(arr(yy, 1)) + 1
    
11.         Next
    
12.         For yy = r To 1 Step -1
    
13.             If d1(arr(yy, 1)) > 1 Then
    
14.                 d1(arr(yy, 1)) = d1(arr(yy, 1)) - 1
    
15.                 .Rows(yy).Delete  '删除重复的最后一个数值行。
    
16.             Else
    
17.                 .Cells(yy, "j") = d(arr(yy, 1))
    
18.             End If
    
19.         Next
    
20.     End With
    
21. End Sub
    

复制代码

shixyi37

grf1973 发表于 2015-3-16 11:31
最好上个附件。

附件来了，谢谢

grf1973

一有附件就清楚了。我是按A列编码合并的，因为发现B列名称书写极不规范，有空格，有错字。当然你可在代码中修改成按B列合并。

1. Sub 合并相同名称()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Worksheets("本年")
   
4.         r = .Range("a65536").End(xlUp).Row
   
5.         arr = .Range("a3:q" & r)
   
6.     End With
   
7.     brr = arr: n = 1
   
8.     For i = 2 To UBound(arr)
   
9.         x = Trim(arr(i, 1))     '按编码合并
   
10.         'x = Trim(arr(i, 2))    '按名称合并
    
11.         If Not d.exists(x) Then
    
12.             n = n + 1
    
13.             d(x) = n
    
14.             For j = 1 To UBound(arr, 2)
    
15.                 brr(n, j) = arr(i, j)
    
16.             Next
    
17.         Else
    
18.             p = d(x)
    
19.             For j = 3 To UBound(arr, 2)
    
20.                 If arr(i, j) > 0 Then brr(p, j) = brr(p, j) + arr(i, j)
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With Sheets(2)
    
25.         .Cells.Clear
    
26.         .[a1].Resize(n, UBound(brr, 2)) = brr
    
27.         .Activate
    
28.     End With
    
29. End Sub
    

复制代码

grf1973

数据量大一定要用数组，象你原代码合并一行删一行，速度太慢。