设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 表内数据按条件筛选
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2130|回复: 9

[已解决]表内数据按条件筛选

[复制链接]
发表于 2017-9-8 11:04 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 正在上班的米米 于 2017-9-13 10:28 编辑

请教各位大侠：（表内颜色是我手动加的，本来是没颜色的）
1、从sheet1中筛选出sheet2（只要列中有一个值大于等于1，就符合条件）2、从sheet2中筛选出sheet3（A列数值相差10的）
3、从sheet2中筛选出sheet4（不满足2的条件，但是列中的数值比较大，如大于10）
最佳答案
月排行榜 / 总排行榜
grf1973
2017-9-12 16:46
结果显示在sheet5,sheet6,sheet7
  1. Sub tt()
  2.     arr = Sheet1.[a2].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     '1  从sheet1中筛选出sheet2（只要列中有一个值大于等于1，就符合条件）
  5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  6.     For i = 1 To UBound(arr)
  7.         For j = 2 To UBound(arr, 2)
  8.             If arr(i, j) >= 1 Then
  9.                 n = n + 1
  10.                 d(Val(arr(i, 1))) = d(Val(arr(i, 1))) & "," & n
  11.                 For jj = 1 To UBound(arr, 2)
  12.                     brr(n, jj) = arr(i, jj)
  13.                 Next
  14.                 Exit For
  15.             End If
  16.         Next
  17.     Next
  18.    
  19.     '2、从sheet2中筛选出sheet3（A列数值相差10的）
  20.     ReDim crr(1 To n, 1 To UBound(arr, 2))
  21.     For i = 1 To UBound(brr)
  22.         x = Val(brr(i, 1))
  23.         If d.exists(x + 10) Then s = s & d(x) & d(x + 10)
  24.     Next
  25.     d.RemoveAll
  26.     srr = Split(s, ",")
  27.     For k = 1 To UBound(srr)
  28.         d(srr(k)) = ""
  29.     Next
  30.     For Each i In d.keys
  31.         m = m + 1
  32.         For j = 1 To UBound(brr, 2)
  33.             crr(m, j) = brr(i, j)
  34.         Next
  35.     Next
  36.    
  37.     '3、从sheet2中筛选出sheet4（不满足2的条件，但是列中的数值比较大，如大于10）
  38.     ReDim drr(1 To n, 1 To UBound(arr, 2))
  39.     For i = 1 To UBound(brr)
  40.         If Not d.exists(i) Then
  41.             For j = 1 To UBound(brr, 2)
  42.                 If brr(i, j) >= 10 Then
  43.                     p = p + 1
  44.                     For jj = 1 To UBound(arr, 2)
  45.                         drr(p, jj) = brr(i, jj)
  46.                     Next
  47.                     Exit For
  48.                 End If
  49.             Next
  50.         End If
  51.     Next
  52.    
  53.     Sheet5.Cells.Clear: Sheet6.Cells.Clear: Sheet7.Cells.Clear
  54.     If n > 0 Then Sheet5.[a1].Resize(n, UBound(arr, 2)) = brr
  55.     If m > 0 Then Sheet6.[a1].Resize(m, UBound(arr, 2)) = crr
  56.     If p > 0 Then Sheet7.[a1].Resize(p, UBound(arr, 2)) = drr
  57. End Sub
复制代码

工作表.rar

84.11 KB, 下载次数: 4

模拟表
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2017-9-11 16:32 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请各位高手帮忙看一下吧。参考了好多，都不行，关键是我没有基础，修改别人的也不会。拜谢各位了！
回复

使用道具 举报

grf1973
发表于 2017-9-12 16:46 | 显示全部楼层    本楼为最佳答案   
工作中最常用的Excel函数公式，全印在一张鼠标垫上
结果显示在sheet5,sheet6,sheet7
  1. Sub tt()
  2.     arr = Sheet1.[a2].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     '1  从sheet1中筛选出sheet2（只要列中有一个值大于等于1，就符合条件）
  5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  6.     For i = 1 To UBound(arr)
  7.         For j = 2 To UBound(arr, 2)
  8.             If arr(i, j) >= 1 Then
  9.                 n = n + 1
  10.                 d(Val(arr(i, 1))) = d(Val(arr(i, 1))) & "," & n
  11.                 For jj = 1 To UBound(arr, 2)
  12.                     brr(n, jj) = arr(i, jj)
  13.                 Next
  14.                 Exit For
  15.             End If
  16.         Next
  17.     Next
  18.    
  19.     '2、从sheet2中筛选出sheet3（A列数值相差10的）
  20.     ReDim crr(1 To n, 1 To UBound(arr, 2))
  21.     For i = 1 To UBound(brr)
  22.         x = Val(brr(i, 1))
  23.         If d.exists(x + 10) Then s = s & d(x) & d(x + 10)
  24.     Next
  25.     d.RemoveAll
  26.     srr = Split(s, ",")
  27.     For k = 1 To UBound(srr)
  28.         d(srr(k)) = ""
  29.     Next
  30.     For Each i In d.keys
  31.         m = m + 1
  32.         For j = 1 To UBound(brr, 2)
  33.             crr(m, j) = brr(i, j)
  34.         Next
  35.     Next
  36.    
  37.     '3、从sheet2中筛选出sheet4（不满足2的条件，但是列中的数值比较大，如大于10）
  38.     ReDim drr(1 To n, 1 To UBound(arr, 2))
  39.     For i = 1 To UBound(brr)
  40.         If Not d.exists(i) Then
  41.             For j = 1 To UBound(brr, 2)
  42.                 If brr(i, j) >= 10 Then
  43.                     p = p + 1
  44.                     For jj = 1 To UBound(arr, 2)
  45.                         drr(p, jj) = brr(i, jj)
  46.                     Next
  47.                     Exit For
  48.                 End If
  49.             Next
  50.         End If
  51.     Next
  52.    
  53.     Sheet5.Cells.Clear: Sheet6.Cells.Clear: Sheet7.Cells.Clear
  54.     If n > 0 Then Sheet5.[a1].Resize(n, UBound(arr, 2)) = brr
  55.     If m > 0 Then Sheet6.[a1].Resize(m, UBound(arr, 2)) = crr
  56.     If p > 0 Then Sheet7.[a1].Resize(p, UBound(arr, 2)) = drr
  57. End Sub
复制代码

工作表.rar

94.29 KB, 下载次数: 9
回复

使用道具 举报

 楼主| 发表于 2017-9-13 09:51 | 显示全部楼层
grf1973 发表于 2017-9-12 16:46
结果显示在sheet5,sheet6,sheet7

拜谢！但是还有筛选的sheet7,不符合条件。我看您的程序里是不是包括了第1列，应该从第2列值开始，行内有大于等于10的筛选出来。
麻烦您再看看！
回复

使用道具 举报

grf1973
发表于 2017-9-13 10:07 | 显示全部楼层
哦，第41句改成 For j = 2 To UBound(brr, 2) 即可。
回复

使用道具 举报

 楼主| 发表于 2017-9-13 10:18 | 显示全部楼层
grf1973 发表于 2017-9-13 10:07
哦，第41句改成 For j = 2 To UBound(brr, 2) 即可。

我也是改的这个，报错
运行时错误‘424’
要求对象
回复

使用道具 举报

grf1973
发表于 2017-9-13 10:22 | 显示全部楼层
没这个问题。你一定是改错了。

工作表.rar

119.36 KB, 下载次数: 5
回复

使用道具 举报

 楼主| 发表于 2017-9-13 10:25 | 显示全部楼层
grf1973 发表于 2017-9-13 10:07
哦，第41句改成 For j = 2 To UBound(brr, 2) 即可。

是我的错，不好意思老师，对的！我自己忘了插入sheet了。
回复

使用道具 举报

 楼主| 发表于 2017-9-13 10:30 | 显示全部楼层
grf1973 发表于 2017-9-13 10:22
没这个问题。你一定是改错了。

对的，是我错了。没有插入sheet。
谢谢，老师！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-26 05:55 , Processed in 0.369895 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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