提取两列重复的数据

zhangmy66

效果见图片，不用列表框 ，把提取的数据放在表格内，实木的，只显示实木就行了，多层板   9
多层板   18
多层板   18
多层板   12
多层板   9
多层板   25
多层板   25
类似筛选
多层板 的子数据包含 18 ，12， 9， 25

zhangmy66

这么快就沉了，求解

xuemei0216

Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr, temp
temp = [a1].CurrentRegion
[a1].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2)
arr = [a1].CurrentRegion
[a1].Resize(UBound(temp), UBound(temp, 2)) = temp
Dim i&, s$
For i = 1 To UBound(arr)
    s = arr(i, 1)
    If arr(i, 2) <> "" Then d(s) = IIf(d(s) = "", arr(i, 2), d(s) & "|" & arr(i, 2))
Next
With [g1]
    .CurrentRegion.ClearContents
    .Resize(d.Count, 1) = Application.Transpose(d.keys)
    .Offset(0, 1).Resize(d.Count, 1) = Application.Transpose(d.Items)
    .Offset(0, 1).Resize(d.Count, 1).TextToColumns Destination:=.Offset(0, 1), OtherChar:="|"
End With
Set d = Nothing
End Sub

zhangmy66

xuemei0216 发表于 2019-10-22 18:35
Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

强大，要理解一阵子了，应用到目标表格还要一段时间。

j90578

xuemei0216 发表于 2019-10-22 18:35
Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

請問 若原始資料不得變更
要如何在陣列temp中去除重複
(How to RemoveDuplicates in temp, without change the original data.)

zhangmy66

xuemei0216 发表于 2019-10-22 18:35
Sub a()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

如果是跨列的呢，数据在  A列，C列