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

13602822168

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

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, n&, r&, dic As Object, vKey, iRowSize&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    r = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    ar = Range("F12:AS" & r).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
    For j = 1 To UBound(ar, 2)
        dic.RemoveAll: n = 0
        For i = 1 To UBound(ar)
            If Len(ar(i, j)) Then dic(ar(i, j)) = dic(ar(i, j)) + 1
        Next i
        For Each vKey In dic.keys
            If dic(vKey) > 1 Then
                n = n + 1
                br(n, j) = vKey
            End If
        Next
        If n > iRowSize Then iRowSize = n
    Next j
   
    [AU12].Resize(iRowSize, UBound(br, 2)) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..............

renkangjizhen

双字典法可一次搞定

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Columns("f:as").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
8.         arr = .Range("f12:as" & r)
   
9.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
10.         For j = 1 To UBound(arr, 2)
    
11.             d.RemoveAll
    
12.             For i = 1 To UBound(arr)
    
13.                 If Len(arr(i, j)) <> 0 Then
    
14.                     d(arr(i, j)) = d(arr(i, j)) + 1
    
15.                 End If
    
16.             Next
    
17.             m = 0
    
18.             For Each aa In d.keys
    
19.                 If d(aa) > 1 Then
    
20.                     m = m + 1
    
21.                     brr(m, j) = aa
    
22.                 End If
    
23.             Next
    
24.         Next
    
25.         .Range("au12").Resize(UBound(brr), UBound(brr, 2)) = brr
    
26.     End With
    
27. End Sub
    

复制代码

chxw68

参与一下。

13602822168

chxw68 发表于 2024-9-7 17:22
参与一下。

感谢，感谢，感谢，重要的事情说三遍！！！！！

sero61

renkangjizhen 发表于 2024-9-7 01:34
双字典法可一次搞定

期待学习双字典法解答

usedrange

1. Sub tt()
   
2.     Dim ar, i%, j%, dic, m%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     m = Cells.SpecialCells(xlCellTypeLastCell).Row
   
5.     ar = [f12].Resize(m, 40)
   
6.     For i = 1 To UBound(ar, 2)
   
7.         r = 0
   
8.         For j = 1 To UBound(ar)
   
9.             
   
10.             If dic.exists(ar(j, i)) And ar(j, i) <> "" Then
    
11.                 Cells(12 + r, i + 46) = ar(j, i)
    
12.                 r = r + 1
    
13.             End If
    
14.             dic(ar(j, i)) = ""
    
15.         Next j
    
16.         dic.RemoveAll
    
17.     Next i
    
18.     Set dic = Nothing
    
19. End Sub

复制代码

usedrange

看看这个是不是你想要的结果