[已解决]字典2列去重复，导出遇见问题

釜底抽薪

工作簿1.zip (14.65 KB, 下载次数: 13)

2021-7-31 11:34 上传

点击文件名下载附件

字典2列去重复，导出遇见问题  请大侠指点 修改

估计我也整错了，要2列合成一列在去重，去完重后又分出2列，单列是可以有重的

最佳答案

月排行榜 / 总排行榜

风林火山

2021-8-2 09:46

Sub 字典去重1()
Dim ar(), br() As Double, cr
ReDim ar(2 To [b65536].End(xlUp).Row, 1 To 2)
For r = 2 To UBound(ar)
    For c = 1 To 2
    ar(r, c) = Cells(r, c + 1)
    Next
Next
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(ar)
    d.Add ar(i, 1) & "\" & ar(i, 2), "" '两列值连接成一个值作为字典键值
Next i
tem = d.keys
[D2].Resize(UBound(tem), 1) = WorksheetFunction.Transpose(tem)

ReDim br(1 To UBound(tem) + 1, 1 To 2) '再将键值拆分成两个值，赋予数组
For i = 0 To UBound(tem)
    cr = Split(tem(i), "\")
    br(i + 1, 1) = cr(0)
    br(i + 1, 2) = cr(1)
Next i
[D2].Resize(d.Count, 2) = br

End Sub

跳转到最佳答案楼层

风林火山

Sub tt()
    Dim k As Long, d, str As String, n As Integer
    For n = 3 To 4
        Set d = CreateObject("scripting.dictionary")
        For k = 3 To Cells(Rows.Count, 3).End(3).Row
            str = Cells(k, 3).Text
            d(str) = ""
        Next
        Cells(3, n + 2).Resize(d.Count, 1) = Application.Transpose(d.keys)
        Set d = Nothing
    Next n
End Sub

风林火山

Sub 字典去重1()
Dim ar(), br() As Double, cr
ReDim ar(2 To [b65536].End(xlUp).Row, 1 To 2)
For r = 2 To UBound(ar)
    For c = 1 To 2
    ar(r, c) = Cells(r, c + 1)
    Next
Next
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(ar)
    d.Add ar(i, 1) & "\" & ar(i, 2), "" '两列值连接成一个值作为字典键值
Next i
tem = d.keys
[D2].Resize(UBound(tem), 1) = WorksheetFunction.Transpose(tem)

ReDim br(1 To UBound(tem) + 1, 1 To 2) '再将键值拆分成两个值，赋予数组
For i = 0 To UBound(tem)
    cr = Split(tem(i), "\")
    br(i + 1, 1) = cr(0)
    br(i + 1, 2) = cr(1)
Next i
[D2].Resize(d.Count, 2) = br

End Sub