数据去重重排

grf1973

用instr可以的，但要把前后两个","全部作为检索字符串的组成部分。

1. Sub zz()
   
2.     Dim d, arr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet1.Range("A1:B" & Sheet1.Range("A1048576").End(xlUp).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         x = arr(i, 1): a = arr(i, 2)
   
7.         If Not d.exists(x) Then
   
8.            d(x) = d(x) & "," & a & ","
   
9.         Else
   
10.             If InStr(d(x), "," & a & ",") = 0 Then d(x) = d(x) & a & ","
    
11.         End If
    
12.     Next
    
13.     dk = d.keys: dt = d.items
    
14.     For i = 0 To UBound(dk)
    
15.         Sheet1.Cells(i + 1, "E") = dk(i)
    
16.         Sheet1.Cells(i + 1, "F") = Mid(dt(i), 2, Len(dt(i)) - 2)
    
17.     Next
    
18. End Sub

复制代码

grf1973

还可以这样

1. Sub zz()
   
2.     Dim d, arr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     arr = Sheet1.Range("A1:B" & Sheet1.Range("A1048576").End(xlUp).Row)
   
6.     For i = 1 To UBound(arr)
   
7.         d(arr(i, 1) & "," & arr(i, 2)) = ""
   
8.     Next
   
9.     For Each k In d.keys
   
10.         x = Split(k, ",")(0)
    
11.         y = Split(k, ",")(1)
    
12.         If Not d1.exists(x) Then
    
13.             d1(x) = y
    
14.             n = n + 1
    
15.             Sheet1.Cells(n, "E") = x
    
16.         Else
    
17.             d1(x) = d1(x) & "," & y
    
18.         End If
    
19.         Sheet1.Cells(n, "F") = d1(x)
    
20.     Next
    
21. End Sub

复制代码

grf1973

还可以这样

1. Sub zz()
   
2.     Dim d, arr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     arr = Sheet1.Range("A1:B" & Sheet1.Range("A1048576").End(xlUp).Row)
   
6.     For i = 1 To UBound(arr)
   
7.         x = arr(i, 1): y = arr(i, 2)
   
8.         k = x & "," & y
   
9.         If Not d.exists(k) Then
   
10.             d(k) = ""
    
11.             If Not d1.exists(x) Then
    
12.                 d1(x) = y
    
13.                 n = n + 1
    
14.                 Sheet1.Cells(n, "E") = x
    
15.             Else
    
16.                 d1(x) = d1(x) & "," & y
    
17.             End If
    
18.             Sheet1.Cells(n, "F") = d1(x)
    
19.         End If
    
20.     Next
    
21. End Sub

复制代码

wzsy2_mrf

Sub zz()
    Dim d, arr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheet1.Range("A1:B" & Sheet1.Range("B1").End(xlDown).Row)
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = arr(i, 2)
        Else
            If InStr(d(arr(i, 1)), "," & arr(i, 2)) = 0 Then '这里用 "," & arr(i, 2)来测试就可以了。
                d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
            End If
        End If
    Next
    Sheet1.Range("E1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

香川群子

大灰狼1976 发表于 2014-6-2 20:53
zax010同学的instr用得确实巧妙，但是有必要提一下，如果B列并不是只有一位数的话，出错的几率是极大的。
...

用Instr 或 like 都可以处理这样的问题。

大灰狼你不知道么？


只需在每个独立元素前加足逗号分隔即可。

If InStr(d(arr(i, 1)), arr(i, 2)) = 0 Then

改成：

If InStr(d(arr(i, 1)) & ",", "," & arr(i, 2) & ",") = 0 Then

需要注意的是：d(arr(i, 1))="," & arr(i, 2)

即，字典中Item始终保证为 ",1,2,5" 类似这样的格式。

香川群子

grf1973 发表于 2014-6-3 09:32
用instr可以的，但要把前后两个","全部作为检索字符串的组成部分。

正解！

完全正确！

大灰狼1976

小的不才，但是这种用法还是懂的，而且以前也这么用过，我只是让注意一下这个问题罢了。
另外，前后加符号等方法，在字符串很长时，执行效率是非常低的，这也是我一般不用它的原因。

LMY123

字典一对查询