如何跨表提取2列数据的唯一值合并到第3表中呢？

古豆

用函数或VBA，把表1“上公示”和表2“下公示”的B列中值提取出来，合并到表3中，重复的只保留一次


跨表提取合并数据.zip (5.52 KB, 下载次数: 36)

2019-6-14 18:08 上传

点击文件名下载附件

约定的童话

Sub 合并()
    Dim i, n, m1, k, k1, m2, arr1, arr2, arr3(1 To 100, 1 To 1), brr(1 To 100, 1 To 1), d As Object
    Set d = CreateObject("scripting.dictionary")
    arr1 = Sheets("上公示").[B1:B11]: arr2 = Sheets("下公示").[B2:B13]
    '以下是数组合并部分
    For m1 = LBound(arr1) To UBound(arr1)
        k = k + 1: arr3(k, 1) = arr1(m1, 1)
    Next
    For m2 = LBound(arr2) To UBound(arr2)
        k1 = k1 + 1: arr3(k + k1, 1) = arr2(m2, 1)
    Next
    '******************
    For i = 2 To UBound(arr3)
        t = arr3(i, 1)
        If Not d.exists(t) Then
            n = n + 1
            d(t) = n
            If n <> i Then
                brr(n, 1) = arr3(i, 1)
            End If
        End If
    Next
    [b2].Resize(UBound(brr), 1) = brr
End Sub

古豆

约定的童话 发表于 2019-6-15 08:15
Sub 合并()
    Dim i, n, m1, k, k1, m2, arr1, arr2, arr3(1 To 100, 1 To 1), brr(1 To 100, 1 To 1) ...

感谢，只是表中不只是固定的十几行数据，我尝试改下以适应多个数据时，结果中间出现了空行……请大神帮修正下

Sub 合并()
    Dim i, n, m1, k, k1, m2, arr1, arr2, arr3(1 To 400, 1 To 1), brr(1 To 400, 1 To 1), d As Object
    Set d = CreateObject("scripting.dictionary")
    arr1 = Sheets("上公示").[B1:B200]: arr2 = Sheets("下公示").[B2:B200]
    '以下是数组合并部分
    For m1 = LBound(arr1) To UBound(arr1)
        k = k + 1: arr3(k, 1) = arr1(m1, 1)
    Next
    For m2 = LBound(arr2) To UBound(arr2)
        k1 = k1 + 1: arr3(k + k1, 1) = arr2(m2, 1)
    Next
    '******************
    For i = 2 To UBound(arr3)
        t = arr3(i, 1)
        If Not d.exists(t) Then
            n = n + 1
            d(t) = n
            If n <> i Then
                brr(n, 1) = arr3(i, 1)
            End If
        End If
    Next
    [b2].Resize(UBound(brr), 1) = brr
End Sub

结果：

古豆

大神在不在？请帮帮我，让代码通用性好一些，因为上公示和下公示表中的姓名不是固定的

古豆

呃，百度了下，改为
    Set cc = Sheets("上公示").Range("B65536").End(xlUp)
    For m1 = LBound(arr1) To cc.Row
替换原来的  For m1 = LBound(arr1) To UBound(arr1)
结果正常了……感谢 约定的童话

windy_hf

古豆 发表于 2019-6-21 09:23
呃，百度了下，改为
    Set cc = Sheets("上公示").Range("B65536").End(xlUp)
    For m1 = LBound(arr ...

有没有公式可以实现这个需求，vb不会用

古豆

windy_hf 发表于 2023-4-11 10:31
有没有公式可以实现这个需求，vb不会用

我也不会，跟着论坛里大佬们学，再修改点

992146

给是这样？