百万条数据,提取唯一值

hellikawhi2

一把小刀闯天下 发表于 2021-9-15 13:14
'19楼附件。去重后结果数：961166，升序输出

'总用时8s左右，对不对就不知道了,自己可以比较一下
...

感谢大佬,感谢大佬,感谢大佬,

xzlu13014

lsdongjh 发表于 2021-9-14 14:00
SQL解决：

你们怎么什么都懂啊

彭pengxingping

是提取A集合的唯一值并去掉与B一样的值的集合吧。我感觉用excel就可以了，VLOOKUP

hellikawhi2

彭pengxingping 发表于 2021-9-16 14:38
是提取A集合的唯一值并去掉与B一样的值的集合吧。我感觉用excel就可以了，VLOOKUP

vlookup确实可以做,但是这个量级的数据,用函数就不好使了

彭pengxingping

hellikawhi2 发表于 2021-9-16 15:16
vlookup确实可以做,但是这个量级的数据,用函数就不好使了

现在快了多少

hellikawhi2

彭pengxingping 发表于 2021-9-16 15:30
现在快了多少

楼上几位大佬的插件或代码都在十秒内完成的,我试过用数组+字典,未响应卡了十分钟没出来,就退了,vlookup也试过,一直未响应,快了不是一点半点啊

perfect131

小白解法，排序加数组
Sub kong()
    t = Timer
    Sheets("数据").[a1].CurrentRegion.Select
    Selection.Sort key1:=Sheets("数据").Cells(1, 1), order1:=xlAscending, Header:=xlYes
    arr = Sheets("数据").Range("a2:a" & Sheets("数据").Cells(Rows.Count, "a").End(3).Row).Value
    Sheets("数据").[a1].CurrentRegion.Select
    Selection.Sort key1:=Sheets("数据").Cells(1, 2), order1:=xlAscending, Header:=xlYes
    brr = Sheets("数据").Range("b2:b" & Sheets("数据").Cells(Rows.Count, "b").End(3).Row).Value
    Sheets("数据").Range("d:d").Select
    Selection.Sort key1:=Sheets("数据").Cells(1, 4), order1:=xlAscending, Header:=xlYes
    crr = Sheets("数据").Range("d2:d" & Sheets("数据").Cells(Rows.Count, "d").End(3).Row).Value
    '''''本身不去重
    Dim k, k1, a, c
    If arr(1, 1) < brr(1, 1) Then
        a = 0
        k = 1
        Do While k < UBound(arr) + 1
            If arr(k, 1) >= brr(1, 1) Then Exit Do
            k = k + 1
        Loop
        If arr(k, 1) > brr(UBound(brr), 1) Then c = 0
        If arr(k, 1) < brr(UBound(brr), 1) Then
            c = 1
            k1 = 1
            Do While k1 < UBound(brr) + 1
                If brr(k1, 1) >= arr(k, 1) Then Exit Do
                k1 = k1 + 1
            Loop
        End If
    Else
        a = 1
        k = 1
        Do While k < UBound(brr) + 1
            If brr(k, 1) >= arr(1, 1) Then Exit Do
            k = k + 1
        Loop
        If brr(k, 1) > arr(UBound(arr), 1) Then c = 0
        If brr(k, 1) < arr(UBound(arr), 1) Then
            c = 1
            k1 = 1
            Do While k1 < UBound(arr) + 1
                If arr(k1, 1) >= brr(k, 1) Then Exit Do
                k1 = k1 + 1
            Loop
        End If
    End If
    Dim kk
    If a = 1 Then
        If c = 0 Then
            ReDim drr(1 To UBound(arr) + UBound(brr))
            kk = 1
            Do While kk < UBound(arr) + UBound(brr) + 1
                If kk < k Then
                    drr(kk) = brr(kk, 1)
                ElseIf kk >= k And kk <= UBound(arr) + k - 1 Then
                    drr(kk) = arr(kk - (k - 1), 1)
                Else
                    drr(kk) = brr(kk - UBound(arr), 1)
                End If
                kk = kk + 1
            Loop
        End If
    Else
        If c = 0 Then
            ReDim drr(1 To UBound(arr) + UBound(brr))
            kk = 1
            Do While kk < UBound(arr) + UBound(brr) + 1
                If kk < k Then
                    drr(kk) = arr(kk, 1)
                ElseIf kk >= k And kk <= UBound(brr) + k - 1 Then
                    drr(kk) = brr(kk - (k - 1), 1)
                Else
                    drr(kk) = arr(kk - UBound(brr), 1)
                End If
                kk = kk + 1
            Loop
        End If
    End If
    If crr(1, 1) < drr(1) Then
        a = 0
        k = 1
        Do While k < UBound(crr) + 1
            If crr(k, 1) >= drr(1) Then Exit Do
            k = k + 1
        Loop
        k1 = 1
        Do While k1 < UBound(drr) + 1
            If drr(k1) >= crr(k, 1) Then Exit Do
            k1 = k1 + 1
        Loop
    Else
        a = 1
        k = 1
        Do While k < UBound(drr) + 1
            If drr(k) >= crr(1, 1) Then Exit Do
            k = k + 1
        Loop
        k1 = 1
        Do While k1 < UBound(crr) + 1
            If crr(k1, 1) >= drr(k) Then Exit Do
            k1 = k1 + 1
        Loop
    End If
    Dim p, p1, p2, d
    p2 = 0
    If a = 0 Then
        p = k1
        p1 = k
        Do While p < UBound(drr) + 1
            d = 0
            If drr(UBound(drr)) < crr(p1, 1) Then Exit Do
            Do While p1 < UBound(crr) + 1
                If drr(p) = crr(p1, 1) Then drr(p) = "": d = 1: Exit Do
                If drr(p) < crr(p1, 1) Then Exit Do
                p1 = p1 + 1
            Loop
            If d = 1 Then p2 = p2 + 1
            p = p + 1
        Loop
        Debug.Print Timer - t
        Dim hrr(), hh
        p = 1
        hh = 1
        ReDim hrr(1 To UBound(drr) - p2, 1 To 1)
        Do While p < UBound(drr) + 1
            If drr(p) <> "" Then
                hrr(hh, 1) = drr(p)
                hh = hh + 1
            End If
            p = p + 1
        Loop
    End If
    '''''''本身去重
   
''    arr = 去重(arr)
''    brr = 去重(brr)
''    crr = 去重(crr)
''    Dim k, k1, a, c
''    If arr(1) < brr(1) Then
''        a = 0
''        k = 1
''        Do While k < UBound(arr) + 1
''            If arr(k) >= brr(1) Then Exit Do
''            k = k + 1
''        Loop
''        If arr(k) > brr(UBound(brr)) Then c = 0
''        If arr(k) < brr(UBound(brr)) Then
''            c = 1
''            k1 = 1
''            Do While k1 < UBound(brr) + 1
''                If brr(k1) >= arr(k) Then Exit Do
''                k1 = k1 + 1
''            Loop
''        End If
''    Else
''        a = 1
''        k = 1
''        Do While k < UBound(brr) + 1
''            If brr(k) >= arr(1) Then Exit Do
''            k = k + 1
''        Loop
''        If brr(k) > arr(UBound(arr)) Then c = 0
''        If brr(k) < arr(UBound(arr)) Then
''            c = 1
''            k1 = 1
''            Do While k1 < UBound(arr) + 1
''                If arr(k1) >= brr(k) Then Exit Do
''                k1 = k1 + 1
''            Loop
''        End If
''    End If
''    Dim kk
''    If a = 1 Then
''        If c = 0 Then
''            ReDim drr(1 To UBound(arr) + UBound(brr))
''            kk = 1
''            Do While kk < UBound(arr) + UBound(brr) + 1
''                If kk < k Then
''                    drr(kk) = brr(kk)
''                ElseIf kk >= k And kk <= UBound(arr) + k - 1 Then
''                    drr(kk) = arr(kk - (k - 1))
''                Else
''                    drr(kk) = brr(kk - UBound(arr))
''                End If
''                kk = kk + 1
''            Loop
''        End If
''    Else
''        If c = 0 Then
''            ReDim drr(1 To UBound(arr) + UBound(brr))
''            kk = 1
''            Do While kk < UBound(arr) + UBound(brr) + 1
''                If kk < k Then
''                    drr(kk) = arr(kk)
''                ElseIf kk >= k And kk <= UBound(brr) + k - 1 Then
''                    drr(kk) = brr(kk - (k - 1))
''                Else
''                    drr(kk) = arr(kk - UBound(brr))
''                End If
''                kk = kk + 1
''            Loop
''        End If
''    End If
''    If crr(1) < drr(1) Then
''        a = 0
''        k = 1
''        Do While k < UBound(crr) + 1
''            If crr(k) >= drr(1) Then Exit Do
''            k = k + 1
''        Loop
''        k1 = 1
''        Do While k1 < UBound(drr) + 1
''            If drr(k1) >= crr(k) Then Exit Do
''            k1 = k1 + 1
''        Loop
''    Else
''        a = 1
''        k = 1
''        Do While k < UBound(drr) + 1
''            If drr(k) >= crr(1) Then Exit Do
''            k = k + 1
''        Loop
''        k1 = 1
''        Do While k1 < UBound(crr) + 1
''            If crr(k1) >= drr(k) Then Exit Do
''            k1 = k1 + 1
''        Loop
''    End If
''    Dim p, p1, p2, d
''    p2 = 0
''    If a = 0 Then
''        p = k1
''        p1 = k
''        Do While p < UBound(drr) + 1
''            d = 0
''            If drr(UBound(drr)) < crr(p1) Then Exit Do
''            Do While p1 < UBound(crr) + 1
''                If drr(p) = crr(p1) Then drr(p) = "": d = 1: Exit Do
''                If drr(p) < crr(p1) Then Exit Do
''                p1 = p1 + 1
''            Loop
''            If d = 1 Then p2 = p2 + 1
''            p = p + 1
''        Loop
''        Debug.Print Timer - t
''        Dim hrr(), hh
''        p = 1
''        hh = 1
''        ReDim hrr(1 To UBound(drr) - p2, 1 To 1)
''        Do While p < UBound(drr) + 1
''            If drr(p) <> "" Then
''                hrr(hh, 1) = drr(p)
''                hh = hh + 1
''            End If
''            p = p + 1
''        Loop
''    End If
    Sheets("数据").Range("f2").Resize(UBound(hrr), 1) = hrr
    Debug.Print Timer - t
End Sub
Function 去重(hm)
    Dim h, h1, h2
    h2 = 1
    Dim hrr()
    h = 1
    Do While h < UBound(hm)
        h1 = h
        If h = 1 Then ReDim Preserve hrr(1 To h2): hrr(h2) = hm(1, 1)
        Do While h1 < UBound(hm) + 1
            If hm(h1, 1) > hm(h, 1) Then
                h2 = h2 + 1
                ReDim Preserve hrr(1 To h2): hrr(h2) = hm(h1, 1)
                h = h1: Exit Do
            End If
            h1 = h1 + 1
        Loop
    Loop
    去重 = hrr
End Function

hellikawhi2

perfect131 发表于 2021-9-17 20:54
小白解法，排序加数组
Sub kong()
    t = Timer

太长了,没太能看懂

花花爱吃肥肉

学习下，目前正在学习SQL

smiletwo