请教一个数组里元素筛选去重后重新放置到单元格的问题

陈正

     首先感谢论坛里各路大佬的支持，菜鸟每次遇到问题，发帖都有人热心回答，非常感谢各位版主及大佬的帮助。
     今天又遇到一个小问题，如照片所示，附件里程序只能写了简单的半截，剩下的需求思考了一下午没弄出结果来，请大佬指教下。
    附件里需求是：
    '1，举例红色部分，同一行中AB列值都相同的只保留一行放入D：E列。
    '2，举例绿色部分，如果B列值相同但A列不同，需要把A列的值合并，有几个合并几个，放入D：E列。
    '3，举例蓝色部分，如果A列B列都是唯一出现仅一次，就直接放到D:E即可。
    最终在E列的管线号是唯一的，不会有重复，在D列得到的图纸号呢，大部分都是PE-001，大部分的PE-002/003。
    再次表示感谢。

liulang0808

是否有这样的可能，要怎么处理啊？

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    r = 0
    For j = 1 To UBound(arr)
        str1 = arr(j, 1) & "##" & arr(j, 2)
        If Not d.exists(str1) Then
            d(str1) = ""
            r = r + 1
            arr(r, 1) = arr(j, 1)
            arr(r, 2) = arr(j, 2)
        End If
    Next j
   
    d.RemoveAll
    rx = 0
    For j = 1 To r
        If Not d.exists(arr(j, 2)) Then
            
            rx = rx + 1
            d(arr(j, 2)) = rx
            arr(rx, 1) = arr(j, 1)
            arr(rx, 2) = arr(j, 2)
        Else
            arr(d(arr(j, 2)), 1) = arr(d(arr(j, 2)), 1) & "\" & Mid(arr(j, 1), 4)
        End If
    Next j
    [g1].Resize(rx, 2) = arr
End Sub

liulang0808

猜了一下，不知道是否对

zlzz1971

请用WPS测试

陈正

liulang0808 发表于 2023-1-12 20:37
是否有这样的可能，要怎么处理啊？

感谢大大的帮助，会有红色这样的情况。一条管线号既重复多次出现，又在不同的图纸号的图纸里出现。
绿色情况，一条管线号不应该出现在两张以上的图纸里，我举例是想在excel里发现这种情况后回去修改图纸。
再次对您表示感谢。

陈正

zlzz1971 发表于 2023-1-12 21:03
请用WPS测试

感谢，但是办公室没有wps，后续我找机会试一下。

笨鸟飞不高

管线号去重.zip (19.69 KB, 下载次数: 7)

2023-1-13 08:28 上传

点击文件名下载附件

阿白124

Sub TestSub()
    Dim i, j, k, arr, brr, key, rng As Range
    arr = Sheet1.Range("a1").CurrentRegion.Value
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        key = CStr(arr(i, 2))
        key1 = CStr(arr(i, 1))
        If Not dic.Exists(key) Then
            Set dic(key) = CreateObject("scripting.dictionary")
            dic(key)(key1) = ""
        Else
            dic(key)(key1) = ""
        End If
    Next
    ReDim brr(1 To dic.Count, 1 To 2)
    k = 1
    For Each r In dic.keys
        brr(k, 1) = Join(dic(r).keys, "\")
        brr(k, 2) = r
        k = k + 1
    Next
    Sheet1.Range("d1").Resize(1000, 100).ClearContents
    Sheet1.Range("d1").Resize(UBound(brr) - LBound(brr) + 1, UBound(brr, 2) - LBound(brr, 2) + 1) = brr
End Sub