楼主
liuguansky |
Q：如何依据范围的有效性的不同选择，返回不同的客户不重复清单？
[分地区提取地区下的单位的不重复清单，有三种格式要分别提取，应该如何实现？]
A：分别用如下代码可以实现：[字典法]
第一个提取：事件代码
- Private Sub Worksheet_Change(ByVal Target As Range)
- If Not Application.Intersect(Target, [a1]) Is Nothing Then
- Dim dic, arr, i&, k%
- Set dic = CreateObject("scripting.dictionary")
- With Sheets("客户管理")
- k = Application.Match([a1], .Range("1:1"), 0)
- arr = .Cells(1, k).Resize(.Cells(.Rows.Count, k).End(3).Row, 1).Value
- End With
- For i = 2 To UBound(arr, 1)
- If arr(i, 1) <> "" Then
- If Not dic.exists(arr(i, 1)) Then dic.Add arr(i, 1), ""
- End If
- Next i
- Range("a2:a" & Rows.Count).Clear
- Cells(2, 1).Resize(dic.Count, 1) = Application.Transpose(dic.Keys)
- Set dic = Nothing
- End If
- End Sub
第二个提取：事件代码：
- Private Sub Worksheet_Change(ByVal Target As Range)
- If Not Application.Intersect(Target, [a1]) Is Nothing Then
- Dim dic, arr, i&, k%, arrt() As String
- Set dic = CreateObject("scripting.dictionary")
- With Sheets("客户管理2")
- k = Application.Match([a1], .Range("1:1"), 0)
- arr = .Cells(1, k).Resize(.Cells(.Rows.Count, k).End(3).Row, 2).Value
- End With
- For i = 2 To UBound(arr, 1)
- If arr(i, 1) <> "" Then
- If Not dic.exists(arr(i, 1) & vbTab & arr(i, 2)) Then dic.Add arr(i, 1) & vbTab & arr(i, 2), ""
- End If
- Next i
- Range("a2:b" & Rows.Count).Clear
- ReDim arrt(1 To dic.Count, 1 To 2)
- arr = dic.Keys
- For i = 1 To dic.Count
- arrt(i, 1) = Split(arr(i - 1), vbTab)(0)
- arrt(i, 2) = Split(arr(i - 1), vbTab)(1)
- Next i
- Cells(2, 1).Resize(i - 1, 2) = arrt
- Set dic = Nothing
- End If
- End Sub
第三个提取：模板代码[需引用对象 scripting.runtime]
- Sub justtest()
- Dim dic As New dictionary, arr, i&
- With Sheets("客户管理3")
- arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row, 2).Value
- End With
- For i = 1 To UBound(arr, 1)
- If arr(i, 1) <> "" Then
- If dic.exists(arr(i, 1)) Then
- If Not dic(arr(i, 1)).exists(arr(i, 2)) Then dic(arr(i, 1)).Add arr(i, 2), ""
- Else
- dic.Add arr(i, 1), arr(i, 2)
- Set dic(arr(i, 1)) = New dictionary
- End If
- End If
- Next i
- Cells.Clear
- Cells(1, 1).Resize(1, dic.Count) = dic.Keys
- For i = 1 To dic.Count
- Cells(2, i).Resize(dic(Cells(1, i).Value).Count, 1) = Application.Transpose(dic(Cells(1, i).Value).Keys)
- Next i
- Set dic = Nothing
- End Sub
具体看附件设置：
|