vba,如何取重复值只要一个，谢谢！

13602822168 · 发表于 2024-9-11 09:26

usedrange 发表于 2024-9-9 15:16
看看这个是不是你想要的结果

如果提取不重复值要改哪里？谢谢！！

usedrange · 发表于 2024-9-11 09:46

13602822168 发表于 2024-9-11 09:26
如果提取不重复值要改哪里？谢谢！！

Sub t2()
Dim ar, i%, j%, dic, m%
Set dic = CreateObject("scripting.dictionary")
m = Cells.SpecialCells(xlCellTypeLastCell).Row
ar = [f12].Resize(m, 40)
For i = 1 To UBound(ar, 2)
      r = 0
      For j = 1 To UBound(ar)
         dic(ar(j, i)) = dic(ar(j, i)) + 1
      Next j
      For j = 1 To UBound(ar)
         If dic(ar(j, i)) = 1 Then
            Cells(12 + r, i + 46) = ar(j, i)
            r = r + 1
         End If
      Next j
      dic.RemoveAll
Next i
Set dic = Nothing
End Sub

Qs18 · 发表于 2024-9-11 17:06

Sub qs() '2024\09\11
Dim arr, cl, rw, dic As Object, zd
Set dic = CreateObject("scripting.dictionary")
With Sheet1
rw = .Cells.SpecialCells(xlCellTypeLastCell).Row
arr = .Range("f12:as" & rw).Value
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For cl = 1 To UBound(arr, 2)
dic.RemoveAll: m = 0
For rw = 1 To UBound(arr)
s = arr(rw, cl)
If s <> Empty Then
If Not dic.exists(s) Then
dic(s) = 0
Else
dic(s) = dic(s) + 1
End If
End If
Next
For Each k In dic.keys
If dic(k) Then
m = m + 1
brr(m, cl) = k
End If
Next
If m > zd Then zd = m
Next
.Range("au12").Resize(rw, UBound(arr, 2)).ClearContents
.Range("au12").Resize(zd, UBound(arr, 2)) = brr
End With
Set dic = Nothing
End Sub

复制代码

Qs18 · 发表于 2024-9-11 17:07

试试。。。。。。。。。

Qs18 · 发表于 2024-9-11 17:09

试试。。。。。。。

13602822168 · 发表于 2024-9-11 20:32

usedrange 发表于 2024-9-11 09:46
Sub t2()
Dim ar, i%, j%, dic, m%
Set dic = CreateObject("scripting.dictionary")

谢谢！！！

13602822168 · 发表于 2024-9-11 20:35

Qs18 发表于 2024-9-11 17:07
试试。。。。。。。。。

感谢帮助！！！！谢谢！！！

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

[求助] vba,如何取重复值只要一个，谢谢！

评分