1. 提取唯一值Sub 提取唯一值() Dim d As New Dictionary Dim arr Dim x As Integer arr = Range('a2:a12') For x = 1 To UBound(arr) d(arr(x, 1)) = '' ‘第二列直接设置为空白就好,不影响 Next x Range('c2').Resize(d.Count) = Application.Transpose(d.keys) End Sub 2. 字典与求和Sub 汇总() Dim d As New Dictionary Dim arr, x arr = Range('d2:e10') For x = 1 To UBound(arr) d(arr(x, 1)) = d(arr(x, 1)) arr(x, 2) 'Key对应的item的值在原来的基础上加新的 Next x Range('f2').Resize(d.Count) = Application.Transpose(d.Keys) Range('g2').Resize(d.Count) = Application.Transpose(d.items) End Sub
3. 多表双向查找Sub 多表() Dim d As New Dictionary Dim x, y Dim arr For x = 27 To 29 arr = Sheets(x).Range('a2').Resize(Sheets(x).Range('a65536').End(xlUp).row - 1, 2) For y = 1 To UBound(arr) d(arr(y, 1)) = arr(y, 2) d(arr(y, 2)) = arr(y, 1) Next y Next x MsgBox d('C1') MsgBox d('张飞') End Sub |
|