删除同一列的重复数据，保留一项

cc8489

删除同一列的重复数据，保留一项，按照生产编号作排列

ykcbf1100

附件供参考。。。

LIUZHU

先按生产编号降序排序，再删除重复项，不需要VBA

ykcbf1100

代码供参考。。。

1. Sub ykcbf()   '//2024.3.11
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 4)
   
8.     End With
   
9.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.         d(s) = i
    
13.     Next
    
14.     For Each k In d.keys
    
15.         m = m + 1
    
16.         For j = 1 To UBound(arr, 2)
    
17.             brr(m, j) = arr(d(k), j)
    
18.         Next
    
19.     Next
    
20.     With Sheets("Sheet2")
    
21.         .UsedRange.Offset(1) = ""
    
22.         .[a1].Resize(1, 4).Interior.Color = 49407
    
23.         With .[a2].Resize(m, 4)
    
24.             .Value = brr
    
25.             .Borders.LineStyle = 1
    
26.             .HorizontalAlignment = xlCenter  '//列居中
    
27.             .VerticalAlignment = xlCenter
    
28.         End With
    
29.     End With
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

于箱长

cnmlgb9998

PQ又快又稳！！！！！！！！！！！！！

cc8489

上面那位老师，我检查了对排序的要求很高，如果顺序完全打乱的，不能做排序的动作，怎么单纯的就是找出来需求的。

无关岁月

问题.7z (8.12 KB, 下载次数: 4)

2024-3-11 16:11 上传

点击文件名下载附件

ykcbf1100

cc8489 发表于 2024-3-11 15:52
上面那位老师，我检查了对排序的要求很高，如果顺序完全打乱的，不能做排序的动作，怎么单纯的就是找出来需 ...

如果数据顺序打乱，代码前面可以先进行数组排序，然后再往下操作。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, strKey$, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    r = 1
   
    For i = 2 To UBound(ar)
        strKey = ar(i, 1)
        If Not dic.exists(strKey) Then
            r = r + 1
            dic(strKey) = Array(r, ar(i, 4))
            For j = 1 To UBound(ar, 2)
                ar(r, j) = ar(i, j)
            Next j
        Else
            br = dic(strKey)
            If ar(i, 4) > br(1) Then
                 br(1) = ar(i, 4)
                 dic(strKey) = br
                 ar(br(0), 4) = ar(i, 4)
            End If
        End If
    Next i
   
    [N1].Resize(r, UBound(ar, 2)) = ar
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub