VBA 字典 快速汇总匹配

Sub DicEx()
    Dim Dic As Object
    Dim aData, aRes
    Dim intX&, iRow&, x&
    On Error Resume Next '出错继续运行
    Set Dic = CreateObject("Scripting.Dictionary")
    aData = Range("a1").CurrentRegion '数据A表来源
    iRow = 1
    ReDim aRes(1 To UBound(aData), 1 To 4) '定义结果数组大小
    For intX = 2 To UBound(aData) '遍历循环数据源
        If Not Dic.exists(aData(intX, 1)) Then '字典中不包含关键字姓名
            iRow = iRow + 1 '累加结果行位置
            Dic(aData(intX, 1)) = iRow '姓名为Key结果行位置为Item存入字典
            aRes(iRow, 1) = aData(intX, 1) '写入结果数组中
            aRes(iRow, 2) = aData(intX, 2)
            aRes(iRow, 3) = 0 '初始化B表数据
            aRes(iRow, 4) = 0 '初识化差异
        Else
            x = Dic(aData(intX, 1)) '提取姓名对应的Item
            aRes(x, 2) = aRes(x, 2) + aData(intX, 2) '累加金额
        End If
    Next
    aData = Range("D1").CurrentRegion '数据B表来源
    For intX = 2 To UBound(aData)
        If Not Dic.exists(aData(intX, 1)) Then '再次判断,为避免B表无该销售员
            iRow = iRow + 1
            Dic(aData(intX, 1)) = iRow
            aRes(iRow, 1) = aData(intX, 1)
            aRes(iRow, 2) = 0
            aRes(iRow, 3) = aData(intX, 2)
            aRes(iRow, 4) = aRes(iRow, 2) - aRes(iRow, 3)
        Else
            x = Dic(aData(intX, 1))
            aRes(x, 3) = aRes(x, 3) + aData(intX, 2)
            aRes(x, 4) = aRes(x, 2) - aRes(x, 3)
        End If
    Next
    aRes(1, 1) = "姓名": aRes(1, 2) = "A表": aRes(1, 3) = "B表": aRes(1, 4) = "差异"
    Range("G1").Resize(iRow, UBound(aRes, 2)) = aRes '输出内容
    Set Dic = Nothing '释放字典内存
End Sub
复制

    strSQL1 = "Select 姓名 ,sum(销售金额) as A表 From " & strSource & " Group By 姓名 "
    strSQL2 = "Select 姓名 ,sum(销售金额) as B表 From " & strSource1 & " Group By 姓名"
    strSQL = "Select a.*,B表,A表-B表 as 差异 From (" & strSQL1 & ")a Left Join (" & strSQL2 & ")b On a.姓名=b.姓名"
复制