[已解决]求VB

lkjhuy

Book2.rar (6.04 KB, 下载次数: 4)

2013-12-3 17:55 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-12-3 18:20

附件请测试，结果输出在C列

1. Private Sub CommandButton1_Click()
   
2. Dim arr, arr1, arr2, i&, j&, k&, l&, m&
   
3. arr = Range("a3:a" & [a65536].End(3).Row)
   
4. arr1 = Range(Cells(2, "e"), Cells(4, [iv2].End(1).Column))
   
5. ReDim arr2(1 To UBound(arr) * UBound(arr1, 2))
   
6. For j = 1 To UBound(arr1, 2)
   
7.   For k = 1 To UBound(arr)
   
8.     For l = 1 To Len(arr(k, 1))
   
9.       If InStr(arr1(3, j), Mid(arr(k, 1), l, 1)) Then Exit For
   
10.     Next l
    
11.     If arr1(1, j) = 0 Then If l = Len(arr(k, 1)) + 1 Then m = m + 1: arr2(m) = arr(k, 1)
    
12.     If arr1(1, j) = 1 Then If l <= Len(arr(k, 1)) Then m = m + 1: arr2(m) = arr(k, 1)
    
13.   Next k
    
14. Next j
    
15. [c1].Resize(UBound(arr2)) = Application.Transpose(arr2)
    
16. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

附件请测试，结果输出在C列

1. Private Sub CommandButton1_Click()
   
2. Dim arr, arr1, arr2, i&, j&, k&, l&, m&
   
3. arr = Range("a3:a" & [a65536].End(3).Row)
   
4. arr1 = Range(Cells(2, "e"), Cells(4, [iv2].End(1).Column))
   
5. ReDim arr2(1 To UBound(arr) * UBound(arr1, 2))
   
6. For j = 1 To UBound(arr1, 2)
   
7.   For k = 1 To UBound(arr)
   
8.     For l = 1 To Len(arr(k, 1))
   
9.       If InStr(arr1(3, j), Mid(arr(k, 1), l, 1)) Then Exit For
   
10.     Next l
    
11.     If arr1(1, j) = 0 Then If l = Len(arr(k, 1)) + 1 Then m = m + 1: arr2(m) = arr(k, 1)
    
12.     If arr1(1, j) = 1 Then If l <= Len(arr(k, 1)) Then m = m + 1: arr2(m) = arr(k, 1)
    
13.   Next k
    
14. Next j
    
15. [c1].Resize(UBound(arr2)) = Application.Transpose(arr2)
    
16. End Sub

复制代码