vba字典取重复值和唯一值（多列）

yejiagui

各位大神老师：
         最近刚刚学习vba字典运用，参考了群里老师的代码，目前已经能做到一列重复数据和唯一值的提取，想请教如何做到多列数据的提取？
         提前感谢了！

清风竹-

Sub 按钮2_Click()
Dim d As Object, arr, brr, crr, i&, k&, j&
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 2)
For i = 2 To UBound(arr)
   For ii = 1 To UBound(arr, 2)
      s = arr(i, ii)
      If s <> "" Then
         d(s) = d(s) + 1
      End If
    Next
Next
    ke = d.keys
    t = d.items
For i = 0 To d.Count - 1
    If t(i) = 1 Then
        k = k + 1
         brr(k, 2) = ke(i)
     Else
       j = j + 1
       brr(j, 1) = ke(i)
    End If
Next
[e:f].ClearContents
[e1:f1] = Array("重复值", "不重复值")
With [e2].Resize(UBound(arr), 2)
.NumberFormat = "@"
.Value = brr
End With

Set d = Nothing
End Sub

shuidisyy

两列都装入数组里，遍历数组
arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
    For j = 1 To UBound(arr, 2)
    s = arr(i, j)
    If s <> "" Then

    End If
    Next j
Next i

yejiagui

shuidisyy 发表于 2020-6-20 17:19
两列都装入数组里，遍历数组
arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To U ...

非常谢谢您抽空指导！完美解决战斗谢谢老师！！

大侠，好！如果两列都有“张三”，重复值会出现两个“张三”，这方便解决吗？

yejiagui

shuidisyy 发表于 2020-6-20 17:19
两列都装入数组里，遍历数组
arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To U ...

刚才尝试了3列，数组遍历模仿您的思路修改了“arr = Range("a1:c" & Cells(Rows.Count, 1).End(xlUp).Row)”，但没有实现之前效果，可能后面代码也要相应修改的原因；来反馈下，也给后面的朋友一点点参考数据；再次谢谢，后面我要经常来论坛跟老师们学习，争取进步！

yejiagui

清风竹- 发表于 2020-6-20 17:03
Sub 按钮2_Click()
Dim d As Object, arr, brr, crr, i&, k&, j&, g&, s$
Set d = CreateObject("scripti ...

感谢老师指教！ 将代码运行后，唯一值可以的，重复值会全部列举出来（如下图效果），谢谢！

清风竹-

yejiagui 发表于 2020-6-21 08:28
感谢老师指教！ 将代码运行后，唯一值可以的，重复值会全部列举出来（如下图效果），谢谢！

Sub 按钮2_Click()
Dim d As Object, arr, brr, crr, i&, k&, j&
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 2)
For i = 2 To UBound(arr)
   For ii = 1 To UBound(arr, 2)
      s = arr(i, ii)
      If s <> "" Then
         d(s) = d(s) + 1
      End If
    Next
Next
    ke = d.keys
    t = d.items
For i = 0 To d.Count - 1
    If t(i) = 1 Then
        k = k + 1
         brr(k, 2) = ke(i)
     Else
       j = j + 1
       brr(j, 1) = ke(i)
    End If
Next
[e:f].ClearContents
[e1:f1] = Array("重复值", "不重复值")
With [e2].Resize(UBound(arr), 2)
.NumberFormat = "@"
.Value = brr
End With

Set d = Nothing
End Sub

一把小刀闯天下

'条件实际不够明确，按列为单位还是全部数据，这里按全部数据来处理，，，

Option Explicit

Sub test()
  Dim arr, dic, i, j, key, n
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Value
  For j = 1 To UBound(arr, 2)
    For i = 2 To UBound(arr, 1)
      If Len(arr(i, j)) Then dic(arr(i, j)) = dic(arr(i, j)) + 1
    Next
  Next
  ReDim arr(1 To dic.Count, 1 To 2), m(2)
  For Each key In dic.keys
    If dic(key) > 1 Then n = 1 Else n = 2
    m(n) = m(n) + 1
    arr(m(n), n) = key
  Next
  [e2].Resize(UBound(arr, 1), 2) = arr
End Sub

一把小刀闯天下

'再凑一个，，，

Option Explicit

Sub test()
  Dim arr, dic(2), i, j, key
  arr = [a1].CurrentRegion.Resize(, 2).Value
  For j = 1 To UBound(arr, 2)
    Set dic(j) = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr, 1)
      If Len(arr(i, j)) Then dic(j)(arr(i, j)) = dic(j)(arr(i, j)) + 1
    Next
  Next
  ReDim arr(1 To UBound(arr, 1), 1 To 2), m(2)
  For i = 1 To 2
    For Each key In dic(i).keys
      If dic(i)(key) = 1 Xor i = 1 Then m(i) = m(i) + 1: arr(m(i), i) = key
    Next
  Next
  [e2].Resize(UBound(arr, 1), 2) = arr
End Sub

yejiagui

一把小刀闯天下 发表于 2020-6-21 09:20
'再凑一个，，，

Option Explicit

老师，您好！周末无事，参考了老师们的思路，我用了两个字典（数据放在a~f列，重复值、惟一值放j，k列，班门弄斧，请大侠们指教！