[已解决]判断出日期接近，金额相同的重复项目，将它们删除掉

屈臣氏VBA

首先感谢【Excel学徒123】老师的帮忙，解决了之前的问题！
现在在运行这代码上，发现对于用在日常工作上，还需再做点调整，
请坛里的精英老师们再帮帮忙！

希望达到最终的效果，请见附图！

判断出日期接近，金额相同的重复项目，将它们删除掉.rar (12.8 KB, 下载次数: 11)

2014-11-12 21:44 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-11-15 05:19

短信收到

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = [j4:o18]
   
6. For i = 2 To UBound(arr)
   
7.     If arr(i, 3) <> "" Then
   
8.         For j = 2 To UBound(arr)
   
9.             If arr(j, 6) = arr(i, 3) Then s = Abs(arr(i, 1) - arr(j, 4)): d(s) = j
   
10.         Next
    
11.            If Join(d.keys, "") <> "" Then
    
12.             If Application.Min(d.keys) < 4 Then '设定天数
    
13.                 n = d(Application.Min(d.keys))
    
14.                 arr(i, 1) = "": arr(i, 3) = ""
    
15.                 arr(n, 4) = "": arr(n, 6) = ""
    
16.             End If
    
17.         End If
    
18.         d.RemoveAll
    
19.     End If
    
20. Next
    
21. Range("t4").Resize(UBound(arr), UBound(arr, 2)) = arr
    
22. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&, j&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [j4:O18]
   
5. For i = 2 To UBound(arr)
   
6.     If arr(i, 3) <> "" Then
   
7.         For j = 2 To UBound(arr)
   
8.             If arr(j, 6) = arr(i, 3) Then s = Abs(arr(i, 1) - arr(j, 4)): d(s) = j
   
9.         Next
   
10.         If Join(d.keys, "") <> "" Then
    
11.             arr(i, 1) = "": arr(i, 3) = ""
    
12.             n = d(Application.Min(d.keys))
    
13.             arr(n, 4) = "": arr(n, 6) = ""
    
14.         End If
    
15.         d.RemoveAll
    
16.     End If
    
17. Next
    
18. Range("t4").Resize(UBound(arr), UBound(arr, 2)) = arr
    
19. End Sub

复制代码

dsmch

………………

dsmch

短信收到

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = [j4:o18]
   
6. For i = 2 To UBound(arr)
   
7.     If arr(i, 3) <> "" Then
   
8.         For j = 2 To UBound(arr)
   
9.             If arr(j, 6) = arr(i, 3) Then s = Abs(arr(i, 1) - arr(j, 4)): d(s) = j
   
10.         Next
    
11.            If Join(d.keys, "") <> "" Then
    
12.             If Application.Min(d.keys) < 4 Then '设定天数
    
13.                 n = d(Application.Min(d.keys))
    
14.                 arr(i, 1) = "": arr(i, 3) = ""
    
15.                 arr(n, 4) = "": arr(n, 6) = ""
    
16.             End If
    
17.         End If
    
18.         d.RemoveAll
    
19.     End If
    
20. Next
    
21. Range("t4").Resize(UBound(arr), UBound(arr, 2)) = arr
    
22. End Sub

复制代码

屈臣氏VBA

dsmch 发表于 2014-11-15 05:19
短信收到

谢谢！！！

屈臣氏VBA

dsmch 发表于 2014-11-15 05:19
短信收到

老师{:30:}http://www.excelpx.com/thread-334740-1-1.html