[已解决]请高手帮忙！

wszbd · 发表于 2013-10-23 02:45

本帖最后由 wszbd 于 2013-10-23 12:01 编辑

新建 Microsoft Excel 工作表.rar (2.48 KB, 下载次数: 10)

qcw811206 · 发表于 2013-10-23 08:28

Public Sub tt()
Dim e_arr()
arr_1 = Range("V1").CurrentRegion
arr_2 = Range("y2:y6")
For Each a In arr_1
For Each b In arr_2
If InStr(a, Left(b, 1)) > 0 And InStr(a, Right(b, 1)) > 0 Then
k = k + 1
ReDim Preserve e_arr(1 To k)
e_arr(k) = a
Exit For
End If
Next
Next
End Sub

复制代码

相同的号码出错例如 77

zjdh · 发表于 2013-10-23 08:29

筛选.rar (7.88 KB, 下载次数: 15)

jio1ye · 发表于 2013-10-23 08:46

本帖最后由 jio1ye 于 2013-10-23 10:34 编辑

Sub shachu()
Dim arr1(), arr2, arr3(), n
arr1 = Range("V1:V" & Range("V65535").End(xlUp).Row)
arr2 = Range("Y2:Y" & Range("Y65535").End(xlUp).Row)
For i = 1 To UBound(arr2)
n = 0
For j = 1 To UBound(arr1)
If IsError(Application.Find(VBA.Left(arr2(i, 1), 1), arr1(j, 1))) Or IsError(Application.Find(VBA.Right(arr2(i, 1), 1), arr1(j, 1))) Then
If VBA.Left(arr2(i, 1), 1) = VBA.Right(arr2(i, 1), 1) And Application.Count(arr1(j, 1), VBA.Right(arr2(i, 1), 1)) = 2 Then
Else
n = n + 1
ReDim Preserve arr3(1 To n)
arr3(n) = arr1(j, 1)
End If
Else
End If
Next j
arr1 = Application.Transpose(arr3)
Next i
range("Z:Z")=""
Range("z1").Resize(UBound(arr1), 1) = arr1
End Sub

复制代码

新建 Microsoft Excel 工作表.rar (192.98 KB, 下载次数: 14)

wszbd · 发表于 2013-10-23 11:39

zjdh 发表于 2013-10-23 08:29

老师真厉害，程序不仅可以过滤二码，还可以过滤单码。

就是有一点Z列是从Z2开始的，能否让其从Z1开始，好复制。

wszbd · 发表于 2013-10-23 11:39

jio1ye 发表于 2013-10-23 08:46

相同的号码出错例如 77

谢谢！

wszbd · 发表于 2013-10-23 11:42

qcw811206 发表于 2013-10-23 08:28
相同的号码出错例如 77

程序怎么不工作

谢谢！

zjdh · 发表于 2013-10-23 13:03

wszbd 发表于 2013-10-23 11:39
老师真厉害，程序不仅可以过滤二码，还可以过滤单码。

就是有一点Z列是从Z2开始的，能否让其从Z1开始， ...

删掉Z1空单元
Sub TEST()
ARR = Range("V1:V" & Range("V65536").End(3).Row)
BRR = Range("Y2:Y" & Range("Y65536").End(3).Row)
For I = 1 To UBound(ARR)
      For J = 1 To UBound(BRR)
         S = 0
         W = ARR(I, 1)
         For T = 1 To Len(BRR(J, 1))
            Q = InStr(W, Mid(BRR(J, 1), T, 1))
            If Q Then
                  S = S + 1
                  W = Left(W, Q - 1) & Right(W, Len(W) - Q)
            End If
         Next
         If S = Len(BRR(J, 1)) Then ARR(I, 1) = "": Exit For
      Next
Next
Range("Z:Z").ClearContents
For I = 1 To UBound(ARR)
      If ARR(I, 1) <> "" Then Range("Z65536").End(3)(2) = ARR(I, 1)
Next
Range("Z1").Delete
End Sub

wszbd · 发表于 2013-10-23 13:50

zjdh 发表于 2013-10-23 13:03
删掉Z1空单元
Sub TEST()
ARR = Range("V1:V" & Range("V65536").End(3).Row)

{:011:}
谢谢!!!

wszbd · 发表于 2013-10-23 23:13

zjdh 发表于 2013-10-23 13:03
删掉Z1空单元
Sub TEST()
ARR = Range("V1:V" & Range("V65536").End(3).Row)

老师你好：
如果做相反的操作，就是把同时含有Y列两个号码的V列号码留下来，过滤后输入到Z列，那么代码该如何修改，请老师赐教？

		自动登录	找回密码
密码			注册