VBA多行多列提取非重复值

yunnanlongyu · 发表于 2023-1-30 20:22

请老师用数组方法，不用字典

chxw68 · 发表于 2023-1-30 20:45

Sub test()
Dim r%, i%, m%
Dim arr, brr()
With Worksheets("sheet1")
arr = .Range("a1").CurrentRegion
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
For k = 1 To m
If brr(k) = arr(i, j) Then
Exit For
End If
Next
If k > m Then
m = m + 1
ReDim Preserve brr(1 To m)
brr(m) = arr(i, j)
End If
End If
Next
Next
.Range("f1").Resize(UBound(brr), 1) = Application.Transpose(brr)
End With
End Sub

复制代码

chxw68 · 发表于 2023-1-30 20:46

使用数组排重比字典麻烦多了，而且速度也慢好多。

太极拍天雄 · 发表于 2023-1-30 20:47

从“xiangbaoan”老师那里获得的一个思路来试试看

shiruiqiang · 发表于 2023-1-30 21:15

和上面两个老师不同的办法

wang-way · 发表于 2023-1-30 21:34

可以实现性价比不高
Sub RemoveSame()
Dim StartTime As Variant
Dim UsedTime As Variant
StartTime = VBA.Timer
Dim arr, ar()
arr = [a1].CurrentRegion.Value
ReDim ar(1 To UBound(arr) * UBound(arr, 2))
n = 0
For Each k In arr
s = "/" & Join(ar, "/") & "/"
If InStr(s, k) = 0 Then
n = n + 1
ar(n) = k
End If
Next k
ReDim Preserve ar(1 To n)
For Each k In ar
Debug.Print k
Next
UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
End Sub

复制代码

leolee82 · 发表于 2023-1-31 01:18

先排序再去重，想研究的话可以看看C++ STL中的算法

tmplinshi · 发表于 2023-1-31 06:40

Sub test()
Dim arr()
arr = RemoveDuplicate([A1:D2])
[F1].Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)
End Sub
Function RemoveDuplicate(arr)
Dim v
Dim i As Long
Dim uniqList As String
Dim uniqArr()
uniqList = vbBack
For Each v In arr
If v <> "" And InStr(1, uniqList, vbBack & v & vbBack, vbTextCompare) = 0 Then
uniqList = uniqList & v & vbBack
i = i + 1
ReDim Preserve uniqArr(1 To i)
uniqArr(i) = v
End If
Next
RemoveDuplicate = uniqArr
End Function

复制代码

3190496160 · 发表于 2023-1-31 08:57

function 单表多列合并到一列新文件()
{
var vs=ActiveSheet.Range("A1").CurrentRegion.Value().flat();
// 过滤掉空值并去重
vs=Array.from(new Set(vs.filter(v=>v!=undefined)));
// 一维数组默认赋值给一行，赋值给一列需要先转置二维
vs = WorksheetFunction.Transpose(vs);
ActiveSheet.Columns("F:F").ClearContents()
ActiveSheet.Range("F1").Resize(vs.length,1).Value2 = vs;
MsgBox("OK!")
}

3190496160 · 发表于 2023-1-31 08:58

用WPS测试

工作簿1.rar (10.62 KB, 下载次数: 3)

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

[求助] VBA多行多列提取非重复值

评分

评分