Excel精英培训网

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

[已解决]VBA查找3位数数据并复制

[复制链接]
发表于 2016-4-28 09:36 | 显示全部楼层 |阅读模式
本帖最后由 爱疯 于 2020-1-13 11:47 编辑

VBA查找3位数数据并复制
最佳答案
2016-5-2 15:32
  1. Sub tt()
  2.     arr = Range("b1:b" & [b65536].End(3).Row)
  3.     ReDim brr(1 To UBound(arr), 1 To 12)
  4.     Dim x(1 To 6)
  5.     tj = [c1]
  6.     For i = 1 To 3   ' 条件的全排列(共6种,378,387,783,738,873,837)
  7.         For j = 1 To 3
  8.             For k = 1 To 3
  9.                 If i <> j And i <> k And j <> k Then
  10.                     s = s + 1
  11.                     x(s) = Mid(tj, i, 1) & Mid(tj, j, 1) & Mid(tj, k, 1)
  12.                 End If
  13.     Next: Next: Next
  14.    
  15.     For i = 1 To UBound(arr)
  16.         arr(i, 1) = Format(arr(i, 1), "00000")
  17.     Next
  18.     For i = 1 To UBound(arr)
  19.         xstr = arr(i, 1)
  20.         For p = 1 To s
  21.             If InStr(xstr, x(p)) > 0 Then Exit For
  22.         Next
  23.         If p < s + 1 Then
  24.             n = n + 1
  25.             brr(n, 2) = xstr
  26.             If i > 1 Then brr(n, 1) = arr(i - 1, 1)
  27.             For k = 1 To 10
  28.                 If i + k <= UBound(arr) Then brr(n, 2 + k) = arr(i + k, 1)
  29.             Next
  30.         End If
  31.     Next
  32.     [d3:o1000] = ""
  33.     If n > 0 Then [d3].Resize(n, 12) = brr
  34. End Sub
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2016-5-2 15:32 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     arr = Range("b1:b" & [b65536].End(3).Row)
  3.     ReDim brr(1 To UBound(arr), 1 To 12)
  4.     Dim x(1 To 6)
  5.     tj = [c1]
  6.     For i = 1 To 3   ' 条件的全排列(共6种,378,387,783,738,873,837)
  7.         For j = 1 To 3
  8.             For k = 1 To 3
  9.                 If i <> j And i <> k And j <> k Then
  10.                     s = s + 1
  11.                     x(s) = Mid(tj, i, 1) & Mid(tj, j, 1) & Mid(tj, k, 1)
  12.                 End If
  13.     Next: Next: Next
  14.    
  15.     For i = 1 To UBound(arr)
  16.         arr(i, 1) = Format(arr(i, 1), "00000")
  17.     Next
  18.     For i = 1 To UBound(arr)
  19.         xstr = arr(i, 1)
  20.         For p = 1 To s
  21.             If InStr(xstr, x(p)) > 0 Then Exit For
  22.         Next
  23.         If p < s + 1 Then
  24.             n = n + 1
  25.             brr(n, 2) = xstr
  26.             If i > 1 Then brr(n, 1) = arr(i - 1, 1)
  27.             For k = 1 To 10
  28.                 If i + k <= UBound(arr) Then brr(n, 2 + k) = arr(i + k, 1)
  29.             Next
  30.         End If
  31.     Next
  32.     [d3:o1000] = ""
  33.     If n > 0 Then [d3].Resize(n, 12) = brr
  34. End Sub
复制代码

符合条件的3位数的查找复制.rar

22.43 KB, 下载次数: 10

评分

参与人数 1 +1 收起 理由
sadz + 1 我和小伙伴都惊呆了

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-8-2 17:18 | 显示全部楼层
grf1973 发表于 2016-5-2 15:32

如果是四位数的呢,应该怎么设置呢
回复

使用道具 举报

发表于 2016-8-4 09:59 | 显示全部楼层
  1. Sub ttt()
  2.     arr = Range("b1:b" & [b65536].End(3).Row)
  3.     ReDim brr(1 To UBound(arr), 1 To 12)
  4.     Dim x(1 To 120)
  5.     tj = [c1]
  6.     For i = 1 To 4   ' 条件的全排列(共24种)
  7.         For j = 1 To 4
  8.             For k = 1 To 4
  9.                 For L = 1 To 4
  10.                     If (i - j) * (i - k) * (i - L) * (j - k) * (j - L) * (k - L) <> 0 Then
  11.                         s = s + 1
  12.                         x(s) = Mid(tj, i, 1) & Mid(tj, j, 1) & Mid(tj, k, 1) & Mid(tj, L, 1)
  13.                     End If
  14.     Next: Next: Next: Next

  15.     For i = 1 To UBound(arr)
  16.         arr(i, 1) = Format(arr(i, 1), "00000")
  17.     Next
  18.     For i = 1 To UBound(arr)
  19.         xstr = arr(i, 1)
  20.         For p = 1 To s
  21.             If InStr(xstr, x(p)) > 0 Then Exit For
  22.         Next
  23.         If p < s + 1 Then
  24.             n = n + 1
  25.             brr(n, 2) = xstr
  26.             If i > 1 Then brr(n, 1) = arr(i - 1, 1)
  27.             For k = 1 To 10
  28.                 If i + k <= UBound(arr) Then brr(n, 2 + k) = arr(i + k, 1)
  29.             Next
  30.         End If
  31.     Next
  32.     [d3:o1000] = ""
  33.     If n > 0 Then [d3].Resize(n, 12) = brr
  34. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
sadz + 1 很给力

查看全部评分

回复

使用道具 举报

发表于 2016-8-4 14:18 | 显示全部楼层
如果条件里的各数可以打乱后不一定作为一个整体的,那么可以有个通用的代码。
  1. Sub tt()
  2.     arr = Range("b1:b" & [b65536].End(3).Row)
  3.     ReDim brr(1 To UBound(arr), 1 To 12)
  4.     Dim L%, tj$  '条件的位数
  5.     Dim tjrr(9), xrr(9)
  6.     tj = [c1]
  7.     For i = 1 To Len(tj)
  8.         p = Val(Mid(tj, i, 1))
  9.         tjrr(p) = tjrr(p) + 1
  10.     Next
  11.    
  12.     For i = 1 To UBound(arr)
  13.         arr(i, 1) = Format(arr(i, 1), "00000")
  14.     Next
  15.    
  16.     For i = 1 To UBound(arr)
  17.         xstr = arr(i, 1)
  18.         For j = 1 To Len(xstr)
  19.             p = Val(Mid(xstr, j, 1))
  20.             xrr(p) = xrr(p) + 1
  21.         Next
  22.         For p = 0 To 9
  23.             If xrr(p) < tjrr(p) Then Exit For
  24.         Next
  25.         If p = 10 Then
  26.             n = n + 1
  27.             brr(n, 2) = xstr
  28.             If i > 1 Then brr(n, 1) = arr(i - 1, 1)
  29.             For k = 1 To 10
  30.                 If i + k <= UBound(arr) Then brr(n, 2 + k) = arr(i + k, 1)
  31.             Next
  32.         End If
  33.         Erase xrr
  34.     Next
  35.     [d3:o1000] = ""
  36.     If n > 0 Then [d3].Resize(n, 12) = brr
  37. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
sadz + 1

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 18:36 , Processed in 0.572901 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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