[已解决]数据合并的小程序

徐淑颖

新建 Microsoft Excel 工作表.zip (3.29 KB, 下载次数: 12)

2013-4-3 09:52 上传

点击文件名下载附件 我有1w行数据左右，但是里面很多医院的同一个产品  被分成2行了，我现在就是想把这两行合并成1行；具体见附件，谢谢老师{:011:}

最佳答案

月排行榜 / 总排行榜

爱疯

2013-4-3 11:05

1. 
   
2. Sub test31()
   
3.     Dim A(), B(), d, i%, j%, s%, t$
   
4. 
   
5.     A = Sheets("Sheet1").Range("A1").CurrentRegion.Value
   
6.     ReDim B(1 To UBound(A), 1 To UBound(A, 2))
   
7.     Set d = CreateObject("scripting.dictionary")
   
8. 
   
9.     For i = 2 To UBound(A)
   
10.         t = A(i, 1) & A(i, 2)    'key
    
11.         If d.exists(t) Then
    
12.             '已存在，则累计和
    
13.             For j = 3 To UBound(A, 2)
    
14.                 B(d(t), j) = B(d(t), j) + A(i, j)
    
15.             Next j
    
16.         Else
    
17.             '不存在，则赋值
    
18.             s = s + 1: d(t) = s
    
19.             B(s, 1) = A(i, 1)
    
20.             B(s, 2) = A(i, 2)
    
21.             For j = 3 To UBound(A, 2)
    
22.                 B(s, j) = A(i, j)
    
23.             Next j
    
24.         End If
    
25.     Next i
    
26. 
    
27.     '输出
    
28.     With Sheets("Sheet1")
    
29.         .Range("k:s").ClearContents
    
30.         If s Then .[k2].Resize(s, UBound(B, 2)) = B
    
31.     End With
    
32. End Sub

复制代码

新建 Microsoft Excel 工作表3.rar (10.08 KB, 下载次数: 17)

2013-7-18 10:22 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

数据透视表很方便哦

孤雁4131

爱疯 发表于 2013-4-3 10:30
数据透视表很方便哦

抢个回答太难了！偌大的excel，我只会透视，，，结果还是慢了一步{:081:}

徐淑颖

爱疯 发表于 2013-4-3 10:30
数据透视表很方便哦

亲，就是因为透视表太麻烦了！才请教的哇，数据有好几十列啊，也有很多行嘛。{:011:}

1032446692

VBA代码的   你看看

爱疯

1. 
   
2. Sub test31()
   
3.     Dim A(), B(), d, i%, j%, s%, t$
   
4. 
   
5.     A = Sheets("Sheet1").Range("A1").CurrentRegion.Value
   
6.     ReDim B(1 To UBound(A), 1 To UBound(A, 2))
   
7.     Set d = CreateObject("scripting.dictionary")
   
8. 
   
9.     For i = 2 To UBound(A)
   
10.         t = A(i, 1) & A(i, 2)    'key
    
11.         If d.exists(t) Then
    
12.             '已存在，则累计和
    
13.             For j = 3 To UBound(A, 2)
    
14.                 B(d(t), j) = B(d(t), j) + A(i, j)
    
15.             Next j
    
16.         Else
    
17.             '不存在，则赋值
    
18.             s = s + 1: d(t) = s
    
19.             B(s, 1) = A(i, 1)
    
20.             B(s, 2) = A(i, 2)
    
21.             For j = 3 To UBound(A, 2)
    
22.                 B(s, j) = A(i, j)
    
23.             Next j
    
24.         End If
    
25.     Next i
    
26. 
    
27.     '输出
    
28.     With Sheets("Sheet1")
    
29.         .Range("k:s").ClearContents
    
30.         If s Then .[k2].Resize(s, UBound(B, 2)) = B
    
31.     End With
    
32. End Sub

复制代码

新建 Microsoft Excel 工作表3.rar (10.08 KB, 下载次数: 17)

2013-7-18 10:22 上传

点击文件名下载附件

徐淑颖

1032446692 发表于 2013-4-3 10:46
VBA代码的   你看看

谢谢，代码我没读懂，运行了好像达不到我需要的效果呢！{:091:}

徐淑颖

爱疯 发表于 2013-4-3 11:05

谢谢 爱老师，效果是达到了！不过代码好复杂啊，对于我这个初学者好难哦！我慢慢研究下{:101:}