[已解决]名称相同,编号合并

琴箫剑气

帮忙看看,C列的效果用公式怎样实现
相同的项合并.rar (9.84 KB, 下载次数: 19)

2016-2-13 10:44 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

baksy

2016-2-13 11:56

附件

跳转到最佳答案楼层

baksy

附件

sry660

1. Sub 合并同类项()
   
2.     Dim arr, i&, d, x
   
3.     arr = Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         x = arr(i, 2)
   
7.         If Not d.exists(x) Then
   
8.             d(x) = arr(i, 1)
   
9.         Else
   
10.             d(x) = d(x) & "-" & arr(i, 1)
    
11.         End If
    
12.     Next
    
13.     For i = 1 To UBound(arr)
    
14.         x = arr(i, 2)
    
15.         If d.exists(x) And i = [b:b].Find(x, lookat:=xlWhole).Row - 1 Then
    
16.             arr(i, 3) = d(x) & ":" & arr(i, 2)
    
17.         End If
    
18.     Next
    
19.     [c2].Resize(UBound(arr), 1) = Application.Index(arr, , 3)
    
20.     Columns(3).AutoFit
    
21. End Sub

复制代码

sry660

代码优化下

1. Sub 合并同类项修改()
   
2.     Dim arr, i&, d, x
   
3.     arr = Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         x = arr(i, 2)
   
7.         d(x) = d(x) & "-" & arr(i, 1)
   
8.     Next
   
9.     For i = 1 To UBound(arr)
   
10.         x = arr(i, 2)
    
11.         If d.exists(x) And i = [b:b].Find(x, lookat:=xlWhole).Row - 1 Then
    
12.             arr(i, 3) = Mid(d(x) & ":" & arr(i, 2), 2)
    
13.         End If
    
14.     Next
    
15.     [c2].Resize(UBound(arr), 1) = Application.Index(arr, , 3)
    
16.     Columns(3).AutoFit
    
17. End Sub

复制代码

xdragon

1. =IF(MATCH(B2,B:B,)=ROW(),TEXT(SUM(INDEX(A:A,N(IF(1,SMALL(IF(B$2:B$11=B2,ROW($2:$11)),ROW(INDIRECT("1:"&COUNTIF(B:B,B2)))))))*10^(COUNTIF(B:B,B2)-ROW(INDIRECT("1:"&COUNTIF(B:B,B2))))),REPT("0-",COUNTIF(B:B,B2)-1)&"0:"&B2),"")

复制代码

数组公式，好麻烦。哈哈，并没取巧。。。

hhzjxss

看看是啥子好东东