根据条件删除单元格内容

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.30
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 6)
   
6.     End With
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1): ss = arr(i, 6)
   
9.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
10.         d(s)(ss) = i
    
11.     Next
    
12.     ReDim brr(1 To UBound(arr), 1 To 6)
    
13.     For Each k In d.keys
    
14.         If d(k).Count = 1 Then
    
15.             m = m + 1
    
16.             brr(m, 1) = k
    
17.             For Each kk In d(k).keys
    
18.                 brr(m, 6) = kk
    
19.             Next
    
20.         Else
    
21.             t = d(k).keys
    
22.             sort1 t, True
    
23.             m = m + 1
    
24.             brr(m, 1) = k
    
25.             brr(m, 6) = t(1)
    
26.         End If
    
27.     Next
    
28.     With Sheets("结果")
    
29.         .UsedRange.Offset(1) = ""
    
30.         .[a2].Resize(m, 6) = brr
    
31.     End With
    
32.     Set d = Nothing
    
33.     MsgBox "OK！"
    
34. End Sub

复制代码

阿哩木

ykcbf1100 发表于 2024-3-30 16:31
参与一下。。。

大佬又是您！！谢谢谢谢！！

yanglinzi

yanglinzi

参与一下。。