[已解决]A中包含B，怎么能使A中的B被消除掉（B为A中的随意顺序）

a543770434

Dear 大神们

help help help           
A中包含B，怎么能使A中的B被消除掉（B为A中的随意顺序） 新增 Microsoft Excel 工作表.zip (6.75 KB, 下载次数: 11)

2016-3-24 15:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sry660

2016-3-24 16:57

1. Sub 清除相同内容()
   
2.     Dim arr, brr, i&, imax&, A, B, x, n&
   
3.     imax = Cells(Rows.Count, 6).End(3).Row
   
4.     arr = Range("f2:k" & imax)
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     For i = 1 To UBound(arr)
   
7.         A = arr(i, 1): B = Split(arr(i, 6), ",")
   
8.         For n = 0 To UBound(B)
   
9.             brr(i, 1) = Replace(Replace(A, B(n), ""), ",,", ",")
   
10.             A = brr(i, 1)
    
11.         Next
    
12.             x = brr(i, 1)
    
13.             If Left(x, 1) = "," Then x = Mid(x, 2)
    
14.             If Right(x, 1) = "," Then x = Left(x, Len(x) - 1)
    
15.             brr(i, 1) = x
    
16.     Next
    
17.     [n2].Resize(UBound(arr), 1) = brr
    
18. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("f1").CurrentRegion
   
5. brr = Range("k1").CurrentRegion
   
6. For i = 2 To UBound(brr)
   
7.     x = Split(brr(i, 1), ",")
   
8.     For j = 0 To UBound(x)
   
9.         d(x(j)) = ""
   
10.     Next
    
11. Next
    
12. For i = 2 To UBound(arr)
    
13.     x = Split(arr(i, 1), ",")
    
14.     p = ""
    
15.     For j = 0 To UBound(x)
    
16.         If Not d.exists(x(j)) Then p = p & "," & x(j)
    
17.     Next
    
18.     arr(i, 1) = Mid(p, 2)
    
19. Next
    
20. Range("a1").Resize(UBound(arr)) = arr
    
21. End Sub
    

复制代码

sry660

1. Sub 清除相同内容()
   
2.     Dim arr, brr, i&, imax&, A, B, x, n&
   
3.     imax = Cells(Rows.Count, 6).End(3).Row
   
4.     arr = Range("f2:k" & imax)
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     For i = 1 To UBound(arr)
   
7.         A = arr(i, 1): B = Split(arr(i, 6), ",")
   
8.         For n = 0 To UBound(B)
   
9.             brr(i, 1) = Replace(Replace(A, B(n), ""), ",,", ",")
   
10.             A = brr(i, 1)
    
11.         Next
    
12.             x = brr(i, 1)
    
13.             If Left(x, 1) = "," Then x = Mid(x, 2)
    
14.             If Right(x, 1) = "," Then x = Left(x, Len(x) - 1)
    
15.             brr(i, 1) = x
    
16.     Next
    
17.     [n2].Resize(UBound(arr), 1) = brr
    
18. End Sub

复制代码

a543770434

非常非常的感謝兩位大神啊{:091:}

a543770434

sry660 发表于 2016-3-24 16:57

dear 大神

能不能在幫忙在原有的基础上在添加點程序。

效果是B为空的时候A也继续保留。也同样是在N竖列。

sry660

a543770434 发表于 2016-3-25 09:59
dear 大神

能不能在幫忙在原有的基础上在添加點程序。

1. Sub 清除相同内容()
   
2.     Dim arr, brr, i&, imax&, A, B, x, n&
   
3.     imax = Cells(Rows.Count, 6).End(3).Row
   
4.     arr = Range("f2:k" & imax)
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     For i = 1 To UBound(arr)
   
7.         A = arr(i, 1): B = arr(i, 6)
   
8.         If Len(B) Then
   
9.             B = Split(arr(i, 6), ",")
   
10.             For n = 0 To UBound(B)
    
11.                 brr(i, 1) = Replace(Replace(A, B(n), ""), ",,", ",")
    
12.                 A = brr(i, 1)
    
13.             Next
    
14.                 x = brr(i, 1)
    
15.                 If Left(x, 1) = "," Then x = Mid(x, 2)
    
16.                 If Right(x, 1) = "," Then x = Left(x, Len(x) - 1)
    
17.                 brr(i, 1) = x
    
18.         Else
    
19.             brr(i, 1) = A
    
20.         End If
    
21.     Next
    
22.     [n2].Resize(UBound(arr), 1) = brr
    
23. End Sub

复制代码

a543770434

不知道怎么用什么激动的心情去感谢你{:091:}
This is really great。