Excel精英培训网

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

[已解决]求助:用VBA如何实现这种筛选功能?

[复制链接]
发表于 2013-5-31 06:38 | 显示全部楼层 |阅读模式
A:C列是数据源
E:G列是想要达到的效果
(湖北省、同一个市所辖的县区放在一起,且县区是不重复的)
希望用VBA代码实现。

非常感谢您的帮助!
最佳答案
2013-5-31 07:15
  1. Sub 取唯一值()
  2.     Dim arr, arrResult()
  3.     Dim i As Long, lRecord As Long, j As Long
  4.     Dim strKey As String
  5.    
  6.     arr = Range("a1").CurrentRegion
  7.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  8.    
  9.     Dim objDic As Object
  10.     Set objDic = CreateObject("scripting.dictionary")
  11.    
  12.     For i = LBound(arr) To UBound(arr)
  13.         Select Case True
  14.             Case Len(arr(i, 3)) = 0 'Len(arr(i, 1)) = 0 Or Len(arr(i, 2)) = 0 Or
  15.             Case Else
  16.                 strKey = arr(i, 1) & "#" & arr(i, 2) & "#" & arr(i, 3)
  17.                 If Not objDic.exists(strKey) Then
  18.                     objDic(strKey) = ""
  19.                     lRecord = lRecord + 1
  20.                     For j = LBound(arr, 2) To UBound(arr, 2)
  21.                         arrResult(lRecord, j) = arr(i, j)
  22.                     Next
  23.                 End If
  24.         End Select
  25.     Next
  26.    
  27.     If lRecord > 0 Then
  28.         Range("n1").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  29.         MsgBox "提取不重复完成"
  30.     End If
  31.     Set objDic = Nothing
  32. End Sub
复制代码
最后你再录一段排序的代码加上就OK了,空值我过滤了。

如何用VBA代码实现这种筛选功能?.rar

4.08 KB, 下载次数: 107

发表于 2013-5-31 07:00 | 显示全部楼层
回复

使用道具 举报

发表于 2013-5-31 07:15 | 显示全部楼层    本楼为最佳答案   
  1. Sub 取唯一值()
  2.     Dim arr, arrResult()
  3.     Dim i As Long, lRecord As Long, j As Long
  4.     Dim strKey As String
  5.    
  6.     arr = Range("a1").CurrentRegion
  7.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  8.    
  9.     Dim objDic As Object
  10.     Set objDic = CreateObject("scripting.dictionary")
  11.    
  12.     For i = LBound(arr) To UBound(arr)
  13.         Select Case True
  14.             Case Len(arr(i, 3)) = 0 'Len(arr(i, 1)) = 0 Or Len(arr(i, 2)) = 0 Or
  15.             Case Else
  16.                 strKey = arr(i, 1) & "#" & arr(i, 2) & "#" & arr(i, 3)
  17.                 If Not objDic.exists(strKey) Then
  18.                     objDic(strKey) = ""
  19.                     lRecord = lRecord + 1
  20.                     For j = LBound(arr, 2) To UBound(arr, 2)
  21.                         arrResult(lRecord, j) = arr(i, j)
  22.                     Next
  23.                 End If
  24.         End Select
  25.     Next
  26.    
  27.     If lRecord > 0 Then
  28.         Range("n1").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  29.         MsgBox "提取不重复完成"
  30.     End If
  31.     Set objDic = Nothing
  32. End Sub
复制代码
最后你再录一段排序的代码加上就OK了,空值我过滤了。

评分

参与人数 1 +6 收起 理由
ligh1298 + 6 很给力!感谢班亲的帮助!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-5-31 08:11 | 显示全部楼层
hwc2ycy 发表于 2013-5-31 07:15
最后你再录一段排序的代码加上就OK了,空值我过滤了。

班亲好!感谢您提供的VBA代码。刚跟着您学习VBA,代码有点看不懂,特别是两个for循环之间的,(字典与数组我只是略知一、二)能不能请您在有时间的时候,帮忙注释一下?谢谢亲!
回复

使用道具 举报

发表于 2013-5-31 21:03 | 显示全部楼层
  1. Sub 取唯一值()
  2.     Dim arr, arrResult()
  3.     Dim i As Long, lRecord As Long, j As Long
  4.     Dim strKey As String
  5.    
  6.     '读取单元格数据到数级
  7.     arr = Range("a1").CurrentRegion
  8.     '定义结果数组,和源数组大小相同
  9.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  10.    
  11.     '字典对象
  12.     Dim objDic As Object
  13.     Set objDic = CreateObject("scripting.dictionary")
  14.    
  15.     '行循环
  16.     For i = LBound(arr) To UBound(arr)
  17.         Select Case True
  18.             '过滤内容非空的情况
  19.             Case Len(arr(i, 3)) = 0 'Len(arr(i, 1)) = 0 Or Len(arr(i, 2)) = 0 Or
  20.             Case Else
  21.                 '字典的关键字 省#市#县
  22.                 strKey = arr(i, 1) & "#" & arr(i, 2) & "#" & arr(i, 3)
  23.                 '如果不存在指定的关键字,则把该行内容写入结果数组
  24.                 If Not objDic.exists(strKey) Then
  25.                     '在字典内登记新的关键字,避免重复
  26.                     objDic(strKey) = ""
  27.                     '结果数组记录数自加1
  28.                     lRecord = lRecord + 1
  29.                     通过列循环把数据写入结果数组
  30.                     For j = LBound(arr, 2) To UBound(arr, 2)
  31.                         arrResult(lRecord, j) = arr(i, j)
  32.                     Next
  33.                 End If
  34.         End Select
  35.     Next
  36.    
  37.     '判断结果数组的个数,避免空数组
  38.     If lRecord > 0 Then
  39.         Range("n1").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  40.         MsgBox "提取不重复完成"
  41.     End If
  42.     '释放字典
  43.     Set objDic = Nothing
  44. End Sub
复制代码

评分

参与人数 1 +6 收起 理由
ligh1298 + 6 赞一个!

查看全部评分

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 15:55 , Processed in 0.441189 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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