如何把一样item的多行合并成一行

人来人_往

各位大虾，请帮帮忙看这个能不能做出来。orz
详细请看附件。

fsydw

A列的值，相同名称的项目，是连续存放的吗？

jysvip

你看看,行不! 我使用的是VBA

人来人_往

是连续存放的。也可以通过排序做到连续存放。

人来人_往

谢谢，我试试看。

人来人_往

可以用。。orz...谢谢了。

jysvip

用公式我就没试过,可能比较复杂.......

alzeng

1. 
   
2. Sub NewLst()
   
3.     Dim Dic As Object, Itm
   
4.     Dim Arr, Ary, k%, i%, m%
   
5. 
   
6.     Arr = [A1].CurrentRegion
   
7.     Set Dic = CreateObject("Scripting.Dictionary")
   
8.     For k = 2 To UBound(Arr)
   
9.         Dic(Arr(k, 1)) = Dic(Arr(k, 1)) + 1
   
10.     Next
    
11. 
    
12.     Ary = Dic.items
    
13.     k = Application.Max(Ary)
    
14.     ReDim Ary(1 To Dic.Count, 1 To (2 + k * 2))
    
15. 
    
16.     For Each Itm In Dic
    
17.         i = i + 1
    
18.         m = 2
    
19.         For k = 2 To UBound(Arr)
    
20.             If Arr(k, 1) = Itm Then
    
21.                 m = m + 1
    
22.                 Ary(i, 1) = Arr(k, 1): Ary(i, 2) = Arr(k, 2)
    
23.                 Ary(i, m) = Arr(k, 3): Ary(i, m + 1) = Arr(k, 4)
    
24.                 m = m + 1
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     Dic.RemoveAll
    
29. 
    
30.     [F5].Resize(i, UBound(Ary, 2)) = Ary
    
31. End Sub
    

复制代码

人来人_往

谢谢楼上。

fsydw

原帖由 alzeng 于 2010-6-4 14:02 发表

Sub NewLst()
    Dim Dic As Object, Itm
    Dim Arr, Ary, k%, i%, m%

    Arr = [A1].CurrentRegion
    Set Dic = CreateObject("Scripting.Dictionary")
    For k = 2 To UBound(Arr)
        Dic( ...

大师的代码就是简洁、高效！学习了！
我也整了一个，不仅效率与您的没法比，代码也不简洁。不过，搞好了，也给楼主做个参考。