网上获取一段去重复提取唯一值的代码。
我希望不是结果列出来,而是把结果来命名新建工作簿。
代码如下:
Sub 提取不重复值()
Dim brr() '声明一个数组brr放结果
Sheets("打卡记录").Select
Set myDic = CreateObject("scripting.dictionary")
'不区分字母大小写比较
myDic.CompareMode = vbTextCompare
'数据源装入数组myarr
myarr = Range("c1:c" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(myarr), 1 To 1)
'标题行不要,开始遍历数组
For i = 2 To UBound(myarr)
'将数据转换成字符串类型,因为字典关键字认为数值和文本型数值是不相等的
s = myarr(i, 1)
If Not myDic.exists(s) Then
'如果字典中不存在s,则作为关键字装入字典,个数累加,结果装入结果数组
myDic(s) = ""
k = k + 1
brr(k, 1) = myarr(i, 1)
End If
Next
[E:E].ClearContents
[E1] = "排重结果"
With [E2].Resize(k, 1)
'设置文本格式,防止某些文本数值变形
.NumberFormat = "@"
.Value = brr
End With
MsgBox "一共有:" & k & "个不重复值。"
'释放字典内存
Set myDic = Nothing
End Sub
我希望不是结果列出来,而是把结果来命名新建工作簿。
代码如下:
Sub 提取不重复值()
Dim brr() '声明一个数组brr放结果
Sheets("打卡记录").Select
Set myDic = CreateObject("scripting.dictionary")
'不区分字母大小写比较
myDic.CompareMode = vbTextCompare
'数据源装入数组myarr
myarr = Range("c1:c" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(myarr), 1 To 1)
'标题行不要,开始遍历数组
For i = 2 To UBound(myarr)
'将数据转换成字符串类型,因为字典关键字认为数值和文本型数值是不相等的
s = myarr(i, 1)
If Not myDic.exists(s) Then
'如果字典中不存在s,则作为关键字装入字典,个数累加,结果装入结果数组
myDic(s) = ""
k = k + 1
brr(k, 1) = myarr(i, 1)
End If
Next
[E:E].ClearContents
[E1] = "排重结果"
With [E2].Resize(k, 1)
'设置文本格式,防止某些文本数值变形
.NumberFormat = "@"
.Value = brr
End With
MsgBox "一共有:" & k & "个不重复值。"
'释放字典内存
Set myDic = Nothing
End Sub