[已解决]请教大家帮忙实现个功能

hwc2ycy

你就要要实现合并的内容再次去重，对不？

Pluto06

hwc2ycy 发表于 2013-3-9 10:19
你就要要实现合并的内容再次去重，对不？

是的.

或者先去(cell-数值)的重, 然后输出.

反正您看怎么合适就怎么操作吧.
呵呵

Pluto06

每个cell 对应数值, 一起重复8遍.

而且cell-A对应的数值是不会重复的. 就是说, Cell-A对应 0&2&16&13之类的 (而不会出现 0&4&7&4&11的情况)
(其他cell也是这样的情况)

Pluto06

hwc2ycy 发表于 2013-3-9 10:19
你就要要实现合并的内容再次去重，对不？

每个cell 对应数值, 一起重复8遍.

而且cell-A对应的数值是不会重复的. 就是说, Cell-A对应 0&2&16&13之类的 (而不会出现 0&4&7&4&11的情况)
(其他cell也是这样的情况)

hwc2ycy

你传个附件。

Pluto06

hwc2ycy 发表于 2013-3-9 12:07
你传个附件。

谢谢哈
Testing1.rar (16.93 KB, 下载次数: 6)

2013-3-9 12:29 上传

点击文件名下载附件

左边输入部分会有很多cells (少于65535), 数量上应该没有什么限制吧?

Pluto06

hwc2ycy 发表于 2013-3-9 12:07
你传个附件。

Testing1.rar (16.93 KB, 下载次数: 0)

2013-3-9 13:55 上传

点击文件名下载附件

Pluto06

hwc2ycy 发表于 2013-3-9 12:07
你传个附件。

大侠帮忙解决下吧. 谢啦
Testing1.rar (16.93 KB, 下载次数: 2)

2013-3-9 19:32 上传

点击文件名下载附件

hwc2ycy

1. Private Sub CommandButton1_Click()
   
2.     Dim dic As Object
   
3.     Dim arr, KeyItem, KeyValue As String
   
4.     Dim strTemp As String
   
5.    
   
6.     Dim lLastrow As Long
   
7. 
   
8.     lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
9.     If lLastrow = 1 Then Exit Sub
   
10.     arr = Range("a2:b" & lLastrow)
    
11. 
    
12.     Set dic = CreateObject("scripting.dictionary")
    
13. 
    
14.     For i = LBound(arr) To UBound(arr)
    
15.         strTemp = dic(arr(i, 1))
    
16.         If Not strTemp Like "*" & arr(i, 2) & "*" Then
    
17.             dic(arr(i, 1)) = dic(arr(i, 1)) & arr(i, 2) & "&"
    
18.         End If
    
19.     Next
    
20.    
    
21.     For Each KeyItem In dic.keys
    
22.         KeyValue = dic(KeyItem)
    
23.         dic(KeyItem) = Left(KeyValue, Len(KeyValue) - 1)
    
24.     Next
    
25.    
    
26.     lLastrow = Cells(Rows.Count, 4).End(xlUp).Row
    
27. 
    
28.     Application.ScreenUpdating = False
    
29. 
    
30.     If lLastrow > 1 Then Range("d2:e" & lLastrow) = ""
    
31. 
    
32.     If dic.Count > 0 Then
    
33.         Range("d2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.keys)
    
34.         Range("e2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.items)
    
35.         MsgBox "OK"
    
36.     End If
    
37. 
    
38.     Set dic = Nothing
    
39.     Application.ScreenUpdating = True
    
40. 
    
41. End Sub

复制代码

大白梨

vb真是厉害，还是先学函数吧，呵呵-----------------