功能：
1.去除重复项
2.自动生成下拉菜单
3.重复项自动求和
附上代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim d1 As Object, d2 As Object, d3 As Object, arr, i As Integer, k, brr, w1 As String, j%
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If Len(arr(i, 3)) Then
If d1(arr(i, 2)) = "" Then '如果是否有数据
d1(arr(i, 2)) = arr(i, 3) '如果该关键字第一次出现
d2(arr(i, 2)) = arr(i, 4)
d3(arr(i, 2)) = arr(i, 5)
'MsgBox "关键字" & arr(i, 1) & Chr(13) & "条目" & d(arr(i, 1))
Else '当该关键字出现了第二次以上
d1(arr(i, 2)) = d1(arr(i, 2)) + arr(i, 3) '将原有的值加上新出现的值保存起来
d2(arr(i, 2)) = d2(arr(i, 2)) + arr(i, 4)
d3(arr(i, 2)) = d3(arr(i, 2)) + arr(i, 5)
'MsgBox "关键字" & arr(i, 1) & Chr(13) & "条目" & d(arr(i, 1))
End If
End If
Next i
j = Target.Row
If Cells(j, 7) = "" Then
For Each k In d1.keys
w1 = w1 & IIf(w1 <> "", ",", "")
w1 = w1 & k
Next k
With Cells(j, 7).Validation
.Delete
If w1 <> "" Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=w1
.InCellDropdown = True
End If
End With
ElseIf j > 1 Then
Cells(j, 8) = d1(Cells(j, 7).Value)
Cells(j, 9) = d2(Cells(j, 7).Value)
Cells(j, 10) = d3(Cells(j, 7).Value)
End If
End Sub