多列分别提取不重复值并排序，谢谢！

a18b88

见附件： 多列分别提取不重复值并排序.rar (6.96 KB, 下载次数: 21)

2019-12-5 13:22 上传

点击文件名下载附件

一把小刀闯天下

'看不太懂凑了一个，，，

Option Explicit

Sub test()
  Dim arr, i, j, t, m, key, dic(5)
  For i = 1 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  arr = [a3].CurrentRegion.Resize(, 4)
  For i = 2 To UBound(arr, 1)
    If Not dic(1).exists(arr(i, 3) & arr(i, 4)) Then
      dic(2)(arr(i, 2) & arr(i, 3)) = 1
      dic(3)(arr(i, 2)) = 1
      dic(4)(arr(i, 3)) = 1
    End If
    dic(1)(arr(i, 3) & arr(i, 4)) = 1
    dic(5)(arr(i, 4)) = 1
  Next
  ReDim arr(1 To UBound(arr, 1), 1 To 5)
  For i = 1 To UBound(dic)
    m = 0
    For Each key In dic(i).keys
      m = m + 1: arr(m, i) = key
    Next
  Next
  For i = 1 To m - 1
    For j = i + 1 To m
      If StrComp(arr(i, 5), arr(j, 5), vbTextCompare) = 1 Then
        t = arr(i, 5): arr(i, 5) = arr(j, 5): arr(j, 5) = t
      End If
    Next
  Next
  [ad4].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

varytina

方法1公式       unique（区域）去重
                   sort（unique（区域））去重排序

方法2操作     去重/排序

deadzlq

PQ参考解法

a18b88

一把小刀闯天下 发表于 2019-12-5 13:49
'看不太懂凑了一个，，，

Option Explicit

谢谢您的帮助！

a18b88

deadzlq 发表于 2019-12-5 14:11
PQ参考解法

谢谢您 deadzlq 老师，

a18b88

一把小刀闯天下 发表于 2019-12-5 13:49
'看不太懂凑了一个，，，

Option Explicit

谢谢您，一把小刀闯天下 老师，真是太完美了，万分感谢！

FOB_FN_L

谁有这种问题的专家级代码------
~~~~~~~~~~一句代码去重并排序~~~~~~

a18b88

varytina 发表于 2019-12-5 14:02
方法1公式       unique（区域）去重
                   sort（unique（区域））去重排序

谢谢您的关注，是个好办法，但是用到系统就不行了。

a18b88

一把小刀闯天下 发表于 2019-12-5 13:49
'看不太懂凑了一个，，，

Option Explicit

大师要是单列提取不重复值并排序怎么写？谢谢您！