[已解决]求个VBA

haeng

提起数.rar (6.39 KB, 下载次数: 17)

2013-11-17 17:04 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-11-17 18:23

如果用的10，直接用10自带的去重复值。

1. Sub tsst()
   
2.     Dim arr, a, j As Byte, k As Byte
   
3.     Dim arrCon
   
4.     Dim arrA(1 To 65536, 1 To 1), lPos As Integer
   
5.    
   
6.     arr = ActiveSheet.UsedRange.Columns(2).Value
   
7.     arrCon = Range(Range("c3"), Range("c3").End(xlToRight)).Value
   
8.    
   
9.     For i = LBound(arrCon, 2) To UBound(arrCon, 2)
   
10.         arrCon(1, i) = Trim(arrCon(1, i))
    
11.     Next
    
12. 
    
13.     For Each a In arr
    
14.         If Len(a) Then
    
15.             For Each b In arrCon
    
16.                 k = 0
    
17.                 For j = 1 To Len(a)
    
18.                     If InStr(b, Mid(a, j, 1)) Then k = k + 1
    
19.                     If j = 2 And k = 0 Then Exit For
    
20.                 Next
    
21.                 If k > 1 Then
    
22.                     lPos = lPos + 1
    
23.                     arrA(lPos, 1) = "'" & a
    
24.                 End If
    
25.             Next
    
26.         End If
    
27.     Next
    
28.    
    
29.     If lPos Then
    
30.         With Columns(1)
    
31.             .Clear
    
32.             .Cells(1, 1).Resize(lPos).Value = arrA
    
33.             .RemoveDuplicates Columns:=1, Header:=xlNo
    
34.         End With
    
35.         MsgBox "完成"
    
36.     End If
    
37. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

这个题不是已经解答过了嘛。

hwc2ycy

[已解决]求助VBA
http://www.excelpx.com/thread-313218-1-1.html

haeng

hwc2ycy 发表于 2013-11-17 17:26
[已解决]求助VBA
http://www.excelpx.com/thread-313218-1-1.html

那个不正确呀

hwc2ycy

haeng 发表于 2013-11-17 17:38
那个不正确呀

结果不正确？

hwc2ycy

那你自己出示一个正确的效果出来。
你现在A列的数据明显就有不符合要求的，例如541

hwc2ycy

haeng

hwc2ycy 发表于 2013-11-17 17:47

是我没写清楚,C3到H3里例15是看成1和5,00是看成0和0,B列里541又有1又有5正合条件呢,

hwc2ycy

haeng 发表于 2013-11-17 17:58
是我没写清楚,C3到H3里例15是看成1和5,00是看成0和0,B列里541又有1又有5正合条件呢,

呵呵，原来的代码取了巧，是有点错误，541我看明白了

hwc2ycy

1. Sub tsst()
   
2.     Dim arr, a, j As Byte, k As Byte
   
3.     Dim arrCon
   
4.     Dim arrA(1 To 65536, 1 To 1), lPos As Integer
   
5.     arr = ActiveSheet.UsedRange.Columns(2).Value
   
6.     arrCon = Range(Range("c3"), Range("c3").End(xlToRight)).Value
   
7.     For i = LBound(arrCon, 2) To UBound(arrCon, 2)
   
8.         arrCon(1, i) = Trim(arrCon(1, i))
   
9.     Next
   
10. 
    
11.     For Each a In arr
    
12.         If Len(a) Then
    
13.             For Each b In arrCon
    
14.                 k = 0
    
15.                 For j = 1 To Len(a)
    
16.                     If InStr(b, Mid(a, j, 1)) Then k = k + 1
    
17.                     If j = 2 And k = 0 Then Exit For
    
18.                 Next
    
19.                 If k > 1 Then
    
20.                     lPos = lPos + 1
    
21.                     arrA(lPos, 1) = "'" & a
    
22.                 End If
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     If lPos Then
    
27.         With Columns(1)
    
28.             .Clear
    
29.             .Cells(1, 1).Resize(lPos).Value = arrA
    
30.         End With
    
31.         MsgBox "完成"
    
32.     End If
    
33. End Sub

复制代码

这样有重复的在A列。