[VBA小工具]提取不重复值

cbtaja · 发表于 2017-1-16 17:08

本帖最后由 cbtaja 于 2017-1-16 22:05 编辑

本工具简介
本工具的功能是很常用的“提取不重复数据”。但相对于EXCEL内置的“删除重复数据”，本工具的特点是：
1、本工具对多重选定区域的数据单条件去重复，而EXCEL内置的则是单一区域的多重条件去重复。
2、本工具可把区域内的数据按指定分隔符进行预先拆分，再以拆分后的结果提取不重复值。
比如对一列单元格内的姓名去重复，但其中有些单元格内填写了多个姓名，以逗号或换行符分隔，本工具即可一步到位完成拆分、去重复。

主函数：

Function DistinctValues(ByVal Rng As Range, Optional ByVal Delimiter As String)
Dim addr$, SubRangeVal, CellValue, ss, Detachable As Boolean, Reg As RegExp
Dim dic As New Dictionary
addr = Rng.Address
Detachable = Len(Delimiter)
If Detachable Then
Set Reg = New RegExp
Reg.Global = True
Reg.IgnoreCase = True
Reg.Pattern = "[^" & Delimiter & "]+"
End If
For Each SubRange In Split(addr, ",")
SubRangeVal = Range(SubRange).Value
If Not IsArray(SubRangeVal) Then SubRangeVal = Array(SubRangeVal)
For Each CellValue In SubRangeVal
If Not Detachable Then
dic(CellValue) = ""
ElseIf Reg.Test(CellValue) Then
Set mas = Reg.Execute(CellValue)
For Each ma In mas
dic(ma.Value) = ""
Next
Else
dic(CellValue) = ""
End If
Next
Next
If dic.Exists("") Then dic.Remove ""
DistinctValues = dic.keys
End Function

复制代码

公用自定义函数（1）：增强的行列转置函数（内置的行列转置函数不能超过65536行，本函数则无限制）

Function ExtraTranspose(ByVal arr) '增强的行列转置函数
Dim tmp, lb1&, ub1&, lb2&, ub2&, i&, j&
If Not IsArray(arr) Then ExtraTranspose = False: Exit Function
lb1 = LBound(arr): ub1 = UBound(arr)
On Error Resume Next
lb2 = LBound(arr, 3)
If Err.Number = 0 Then Exit Function Else Err.Clear '仅限于二维或一维的行列转置
lb2 = LBound(arr, 2)
If Err.Number Then
Err.Clear
ReDim tmp(lb1 To ub1, 0 To 0)
For i = LBound(arr) To UBound(arr)
tmp(i, 0) = arr(i)
Next
Else
lb2 = LBound(arr, 2): ub2 = UBound(arr, 2)
ReDim tmp(lb2 To ub2, lb1 To ub1)
For j = lb2 To ub2
For i = lb1 To ub1
tmp(j, i) = arr(i, j)
Next
Next
End If
ExtraTranspose = tmp
End Function

复制代码

公用自定义函数（2）：对手工输入的正则表达式Pattern字符串参数做预处理

Function regChar$(ByVal spcPatternChar$)
'为表示正则表达式的特殊元字符本身而添加转义符
'对正则表达式的Pattern参数做预处理
Dim s$
spcCharacters = "$^(){}[]*.?|\/"
regChar = spcPatternChar
For i = Len(regChar) To 1 Step -1
s = Mid(regChar, i, 1)
If InStr(spcCharacters, s) Then _
regChar = Replace(regChar, s, "" & s)
Next
End Function

复制代码

cbtaja · 发表于 2017-1-16 17:24

本帖最后由 cbtaja 于 2017-1-16 22:08 编辑

附件已经更新：

提取唯一值.rar (18.22 KB, 下载次数: 359)

yaoihih · 发表于 2017-1-23 23:24

谢谢分享，收下了。

jjmysjg · 发表于 2017-1-24 07:09

本帖最后由 jjmysjg 于 2017-1-24 07:19 编辑

谢谢楼主，怎么使用？

xinlan6 · 发表于 2017-1-26 20:07

收下，备用，谢谢！

a1308737 · 发表于 2017-1-29 23:56

看上去非常不错

qdchyq · 发表于 2018-12-18 21:32

楼主，此代码怎么使用

jhegzwjb2016 · 发表于 2022-4-22 13:25

感谢您的分享！

gwjkkkkk · 发表于 2022-4-25 16:02

谢谢楼主，认真学习。。。

		自动登录	找回密码
密码			免费注册

[原创] [VBA小工具]提取不重复值

评分

评分