[已解决]附件重新整理后求助：删除所 ...

水木

附件重新整理后求助：删除所有单元格中与关键字相同的字(包括：归纳后删除相同的字符）.zip (14.67 KB, 下载次数: 10)

2014-12-6 07:17 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-6 09:49

论坛原因，上传代码$自动变为$$

跳转到最佳答案楼层

qh8600

1. Sub demo()
   
2.     Dim ar, d As Object, d1 As Object, a, b, re(), br(), xx
   
3.     a = Cells(Rows.Count, 8).End(3).Row
   
4.     b = Cells(1, Columns.Count).End(1).Column
   
5.     ar = Range(Cells(2, 8), Cells(a, b))
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     ReDim re(1 To UBound(ar), 1 To 2)
   
9.     For i = 1 To UBound(ar)
   
10.         If Not d.Exists(ar(i, 1)) Then
    
11.             cnt = cnt + 1
    
12.             d(ar(i, 1)) = cnt
    
13.             re(cnt, 1) = ar(i, 1)
    
14.         End If
    
15.         For j = 1 To UBound(ar, 2)
    
16.             re(d(ar(i, 1)), 2) = Replace(re(d(ar(i, 1)), 2) & ar(i, j), ar(i, 1), "")
    
17.         Next
    
18.         If Len(re(d(ar(i, 1)), 2)) > m Then m = Len(re(d(ar(i, 1)), 2))
    
19.     Next
    
20.     ReDim br(1 To d.Count, 1 To m + 1)
    
21.     For i = 1 To d.Count
    
22.         br(i, 1) = re(i, 1)
    
23.         For j = 1 To Len(re(i, 2))
    
24.             d1(Mid(re(i, 2), j, 1)) = ""
    
25.         Next
    
26.         xx = d1.keys
    
27.         For j = 0 To UBound(xx)
    
28.             br(i, j + 2) = xx(j)
    
29.         Next
    
30.       d1.RemoveAll
    
31.     Next
    
32.     Sheet2.Range("h2").Resize(UBound(br), UBound(br, 2)) = br
    
33. End Sub
    
34. 
    
35. 
    

复制代码

附件楼下

qh8600

附件重新整理后求助：删除所有单元格中与关键字相同的字(包括：归纳后删除相同的字符）.rar (23.32 KB, 下载次数: 3)

2014-12-6 09:35 上传

点击文件名下载附件
楼主试试

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, k%, s%, zf$$, z$$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 8)
   
6. For i = 2 To UBound(arr)
   
7.     s = 0
   
8.     For j = 9 To UBound(arr, 2)
   
9.         arr(i, j) = Replace(arr(i, j), arr(i, 8), "")
   
10.         zf = arr(i, j)
    
11.         For k = 1 To Len(zf)
    
12.             z = Mid(zf, k, 1)
    
13.             If Not d.exists(z) Then
    
14.                 d(z) = ""
    
15.                 s = s + 1
    
16.                 brr(i - 1, s) = z
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     If s > n Then n = s
    
21.     d.RemoveAll
    
22. Next
    
23. Range("i2").Resize(UBound(brr), n) = brr
    
24. End Sub

复制代码

dsmch

论坛原因，上传代码$自动变为$$