求教怎样将不同列中不同行的单元格内容相同的整理到同一列中去！

cnko

表1：


表2：


如上面两个表，有没有方法能将表1内容比较快捷地整理成表2的内容

就是将不同列中不同行的单元格内容相同的整理到同一列中去。

现在我采用的方法是：

1.Ctrl+F 查找一个内容然后按Ctrl+A全选，

2.然后用论坛中的“易用宝”软件中的“多区域复制”功能将此选中区域内容复制粘贴到一个空的地方，




3.然后将这一块全部选中，复制到文本处理软件中，去除空格，



4.再复制回excel就是在同一列了，要求就是行号不变，但相同内容在同一列

最后的效果：


但这个的方法缺点就是太慢了，因为要处理的样本太大。

希望可以找到比较快捷的方法，请高手指教下，不胜感激！


这是样本文件： 将不同列中不同行的单元格内容相同的整理到同一列.rar (7.66 KB, 下载次数: 94)

2012-7-22 20:50 上传

点击文件名下载附件

yangyangzhifeng

要是一行中有重复项，不知要用什么规则，请明示。

cnko

yangyangzhifeng 发表于 2012-7-22 21:05
要是一行中有重复项，不知要用什么规则，请明示。

一般我处理的数据同一行中是没有重复项的，但万一有，只要取一行中第一次出现的数值就行了，后面的不管它

yangyangzhifeng

哦，试试，数据输出到sheet2，请现引用Microsoft scripting Runtime(因为使用字典)

1. Sub test()
   
2.     Dim arr, i&, j&, irow, brr, crr
   
3.     Dim d As New Dictionary
   
4.     irow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
5.     arr = Sheet1.Range("b4:h" & irow)
   
6.     For i = 1 To UBound(arr)
   
7.         For j = 1 To UBound(arr, 2)
   
8.             If arr(i, j) <> "" Then
   
9.                 If Not d.Exists(arr(i, j)) Then d(arr(i, j)) = i Else d(arr(i, j)) = d(arr(i, j)) & "|" & i
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     ReDim crr(1 To UBound(arr), 1 To d.Count)
    
14.     For j = 0 To d.Count - 1
    
15.         brr = Split(d(d.Keys(j)), "|")
    
16.         For i = 0 To UBound(brr)
    
17.             crr(brr(i), j + 1) = d.Keys(j)
    
18.         Next
    
19.     Next
    
20.     Sheet2.UsedRange.ClearContents
    
21.     Sheet2.Range("a1").Resize(UBound(crr), UBound(crr, 2)) = crr
    
22. End Sub
    

复制代码

yangyangzhifeng

请参考附件
将不同列中不同行的单元格内容相同的整理到同一列.rar (15.47 KB, 下载次数: 210)

2012-7-22 21:31 上传

点击文件名下载附件

cnko

谢谢您了！我这边执行之后，产生这样的提示：编译错误：用户定义类型未定义。我对VBA不熟悉的
刚才没看到你这边上传的附件，我再去试下看

yangyangzhifeng

在VBE中，工具菜单=》引用=》选中Microsoft Scripting Runtime=》确定，再运行试试。

doitbest

1. Public Sub format1()
   
2. Dim ar, br(), i, j, c
   
3. Dim d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. ar = ActiveSheet.UsedRange
   
6. ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
7. For i = 1 To UBound(ar)
   
8.     For j = 1 To UBound(ar, 2)
   
9.         If ar(i, j) <> "" And Not d.exists(ar(i, j)) Then d(ar(i, j)) = ""
   
10.     Next
    
11. Next
    
12. For i = 1 To UBound(ar)
    
13.     For j = 1 To UBound(ar, 2)
    
14.         If ar(i, j) <> "" And d.exists(ar(i, j)) Then
    
15.             c = Application.Match(ar(i, j), d.keys, 0)
    
16.             br(i, c) = ar(i, j)
    
17.         End If
    
18.     Next
    
19. Next
    
20. [i1].Resize(UBound(ar), UBound(ar, 2)) = br
    
21. End Sub
    

复制代码

doitbest

请参考附件

cnko

已经得到我要的效果，非常感谢您啊！{:soso_e100:} yangyangzhifeng
再请问下您，如果我的原始数据，行数和列数有变化怎么办？比如说，我的原始数据是20行30列，那这段代码要修改吗？