Excel VBA高级编程 -自动去除重复项 自动求和

大家好，我是陈小虾，是一名自动化方向的IT民工。写博客是为了记录自己的学习过程，通过不断输出倒逼自己加速成长。但功能说明：由于水平有限，博客中难免会出现一些BUG，或者有更优方案恳请各位大佬不吝赐教！微信公众号：万能的Excel 

功能说明：

工作中经常需要从数据库中统计某一项的全部数据，人工统计不仅繁琐而且容易出错

本工作表使用VBA实现了如下功能：

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

关注公众号：万能的Excel     并回复【自动求和】获取源文件！