[已解决]求助：删除拆分合并同类所有 ...

水木

求助：删除拆分合并同类所有单元格中与关键字相同的字。.rar (23.59 KB, 下载次数: 7)

2014-12-5 11:23 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

qh8600

2014-12-5 12:21

1. Sub demo()
   
2.     Dim ar, d As Object, a, b, re(), br(), cnt
   
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.     ReDim re(1 To UBound(ar), 1 To 2)
   
8.     For i = 1 To UBound(ar)
   
9.         If Not d.Exists(ar(i, 1)) Then
   
10.             cnt = cnt + 1
    
11.             d(ar(i, 1)) = cnt
    
12.             re(cnt, 1) = ar(i, 1)
    
13.         End If
    
14.         For j = 1 To UBound(ar, 2)
    
15.             re(d(ar(i, 1)), 2) = Replace(re(d(ar(i, 1)), 2) & ar(i, j), ar(i, 1), "")
    
16.         Next
    
17.         If Len(re(d(ar(i, 1)), 2)) > m Then m = Len(re(d(ar(i, 1)), 2))
    
18.     Next
    
19.     ReDim br(1 To d.Count, 1 To m + 1)
    
20.     For i = 1 To d.Count
    
21.         br(i, 1) = re(i, 1)
    
22.         For j = 1 To m
    
23.             br(i, j + 1) = Mid(re(i, 2), j, 1)
    
24.         Next
    
25.     Next
    
26.     Sheet2.Range("h2").Resize(UBound(br), UBound(br, 2)) = br
    
27. End Sub

复制代码

求助：删除所有单元格中与关键字相同的字。.rar (21.37 KB, 下载次数: 8)

2014-12-5 12:21 上传

点击文件名下载附件

楼主试试

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Const n As Integer = 100
   
3. Application.ScreenUpdating = False
   
4. For i = 2 To Range("h65536").End(xlUp).Row
   
5.     Cells(i, "i").Resize(1, n).Replace Cells(i, "h"), "", lookat:=xlPart
   
6. Next
   
7. Application.ScreenUpdating = True
   
8. End Sub

复制代码

qh8600

1. Sub demo()
   
2.     Dim ar, d As Object, a, b, re(), br(), cnt
   
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.     ReDim re(1 To UBound(ar), 1 To 2)
   
8.     For i = 1 To UBound(ar)
   
9.         If Not d.Exists(ar(i, 1)) Then
   
10.             cnt = cnt + 1
    
11.             d(ar(i, 1)) = cnt
    
12.             re(cnt, 1) = ar(i, 1)
    
13.         End If
    
14.         For j = 1 To UBound(ar, 2)
    
15.             re(d(ar(i, 1)), 2) = Replace(re(d(ar(i, 1)), 2) & ar(i, j), ar(i, 1), "")
    
16.         Next
    
17.         If Len(re(d(ar(i, 1)), 2)) > m Then m = Len(re(d(ar(i, 1)), 2))
    
18.     Next
    
19.     ReDim br(1 To d.Count, 1 To m + 1)
    
20.     For i = 1 To d.Count
    
21.         br(i, 1) = re(i, 1)
    
22.         For j = 1 To m
    
23.             br(i, j + 1) = Mid(re(i, 2), j, 1)
    
24.         Next
    
25.     Next
    
26.     Sheet2.Range("h2").Resize(UBound(br), UBound(br, 2)) = br
    
27. End Sub

复制代码

求助：删除所有单元格中与关键字相同的字。.rar (21.37 KB, 下载次数: 8)

2014-12-5 12:21 上传

点击文件名下载附件

楼主试试