Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1907|回复: 4

[已解决]VBA求助

[复制链接]
发表于 2013-1-16 17:28 | 显示全部楼层 |阅读模式
Book1.rar (4.87 KB, 下载次数: 11)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-1-16 18:55 | 显示全部楼层

  1. Sub 按钮1_Click()
  2.     Dim A, B, C, i, j, k, str, n, s
  3.     A = [a2:b2]
  4.     B = Range("c3:c" & Range("c65536").End(xlUp).Row)
  5.     ReDim C(1 To UBound(B) * 2, 1 To 1) As String
  6.     For i = 1 To UBound(A, 2)
  7.         For j = 1 To UBound(B)
  8.             n = 0
  9.             For k = 1 To Len(CStr(B(j, 1)))
  10.                 str = Mid(CStr(B(j, 1)), k, 1)
  11.                 If InStr(A(1, i), str) Then n = n + 1
  12.             Next k
  13.             If n = 3 Then
  14.                 s = s + 1
  15.                 C(s, 1) = B(j, 1)
  16.             End If
  17.         Next j
  18.     Next i
  19.     Columns(6).ClearContents
  20.     [f2].Resize(s) = C
  21. End Sub
复制代码
Book1b.rar (10.43 KB, 下载次数: 5)

评分

参与人数 1 +3 收起 理由
yangming27 + 3

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-1-16 19:22 | 显示全部楼层
爱疯 发表于 2013-1-16 18:55

如335这样有重数只能算是两个数才行
回复

使用道具 举报

发表于 2013-1-16 20:14 | 显示全部楼层    本楼为最佳答案   

  1. Sub Test2()
  2.     Dim A, B, C
  3.     Dim i, j, k, n, s
  4.     Dim str1$, str2$
  5.    
  6.     A = [a2:b2]
  7.     B = Range("c3:c" & Range("c65536").End(xlUp).Row)
  8.     ReDim C(1 To UBound(B) * 2, 1 To 1) As String
  9.     For i = 1 To UBound(A, 2)
  10.         For j = 1 To UBound(B)
  11.             n = 0
  12.             str1 = CStr(B(j, 1))
  13.             For k = 1 To Len(CStr(B(j, 1)))
  14.                 str2 = Mid(CStr(B(j, 1)), k, 1)
  15.                 If InStr(A(1, i), str2) Then n = n + 1
  16.                 '避免检查重数,形如:335,355
  17.                 str1 = VBA.Replace(str1, str2, "")
  18.                 If Len(str1) + k <> 3 Then Exit For
  19.             Next k
  20.             If n = 3 Then
  21.                 s = s + 1
  22.                 C(s, 1) = B(j, 1)
  23.             End If
  24.         Next j
  25.     Next i
  26.     Columns(6).ClearContents
  27.     [f2].Resize(s) = C
  28. End Sub

复制代码
回复

使用道具 举报

发表于 2013-1-16 21:01 | 显示全部楼层
Private Sub CommandButton1_Click()
Dim arr, brr(), crr()
arr = [a2:b2]
endrow = [c65536].End(3).Row
brr = Range("c3:c" & endrow)
For k = 1 To endrow - 2
For i = 1 To 2
For j = 1 To Len(arr(1, i))
    If InStr(brr(k, 1), Mid(arr(1, i), j, 1)) <> 0 Then
        s = s + 1
        If s = 3 Then
            ss = ss + 1
            ReDim Preserve crr(1 To ss)
            crr(ss) = brr(k, 1)
        End If
    End If
Next j
s = 0
Next i
Next k
Range("d3").EntireColumn.Clear
Range("d3").Resize(ss, 1) = Application.Transpose(crr)
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 21:45 , Processed in 0.386577 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表