[已解决]去除多余的行数

llplj

现在碰到了一个问题，就是有多行记录，但是需要把订单号相同，金额相反的行数删除，不知道怎么能够一次性把这些数据找出来，请帮忙看一下，谢谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2016-2-22 10:12

2.rar (17.05 KB, 下载次数: 9)

2016-2-22 10:10 上传

点击文件名下载附件



Sub test()
    Dim A, d, k, t
    Dim i, x, s

    Set d = CreateObject("scripting.dictionary")
    A = Range("a1").CurrentRegion
    For i = 3 To UBound(A)
        x = A(i, 1) & "|" & Abs(A(i, 2))
       d(x) = d(x) + 1
    Next i
    k = d.keys: t = d.items

    For i = 0 To UBound(k)
        If t(i) = 1 Then
            s = s + 1
            A(s, 1) = VBA.Split(k(i), "|")(0)
            A(s, 2) = VBA.Split(k(i), "|")(1)
        End If
    Next i

    [j:k].ClearContents
    [j3].Resize(s, 2) = A
End Sub



觉得应该有不用代码的简单办法才对，没想着

跳转到最佳答案楼层

爱疯

2.rar (17.05 KB, 下载次数: 9)

2016-2-22 10:10 上传

点击文件名下载附件



Sub test()
    Dim A, d, k, t
    Dim i, x, s

    Set d = CreateObject("scripting.dictionary")
    A = Range("a1").CurrentRegion
    For i = 3 To UBound(A)
        x = A(i, 1) & "|" & Abs(A(i, 2))
       d(x) = d(x) + 1
    Next i
    k = d.keys: t = d.items

    For i = 0 To UBound(k)
        If t(i) = 1 Then
            s = s + 1
            A(s, 1) = VBA.Split(k(i), "|")(0)
            A(s, 2) = VBA.Split(k(i), "|")(1)
        End If
    Next i

    [j:k].ClearContents
    [j3].Resize(s, 2) = A
End Sub



觉得应该有不用代码的简单办法才对，没想着

ws278106483

加了几个辅助列。

tjshenjian

不知是否能够满足楼主的要求

sry660

1. Sub t()
   
2.     Dim arr, i&, x, d, brr, n&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = [a2:b14]
   
5.     ReDim brr(1 To UBound(arr), 1 To 2)
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 1) & Abs(arr(i, 2))
   
8.         If Not d.exists(x) Then
   
9.             d(x) = i
   
10.         Else
    
11.             d.Remove (x)
    
12.         End If
    
13.     Next
    
14.     For Each x In d.items
    
15.         n = n + 1
    
16.         brr(n, 1) = arr(x, 1)
    
17.         brr(n, 2) = arr(x, 2)
    
18.     Next
    
19.     [i3].Resize(UBound(arr), UBound(arr, 2)) = brr
    
20. End Sub

复制代码

llplj

爱疯 发表于 2016-2-22 10:12
Sub test()
    Dim A, d, k, t
    Dim i, x, s

我也在想是不是有不用VBA的方法 不过没想出来。

llplj

ws278106483 发表于 2016-2-22 10:13
加了几个辅助列。

没法下载  不知道是不是公司网络限制的问题，谢谢你的回复 ！

llplj

tjshenjian 发表于 2016-2-22 10:20
不知是否能够满足楼主的要求

你好，你的公式能得到一样的结果  不过有没有更简单的方法 不太看得懂 不过还是谢谢你的回复

llplj

sry660 发表于 2016-2-22 10:42

谢谢你的回复  很好用