求一个汇总的VBA程序（万分感谢zhaogang1960前辈）

puresway

新手，刚接触VBA，研究了没有成效，还望高人指点

zhaogang1960

原帖由 puresway 于 2011-2-14 20:56 发表
前辈，销售人员信息如果不是一对一，而是多对一，如何实现正确匹配、汇总呢，比如郑州、开封、洛阳、平顶山的销售人员都是周培芳，这样的话造成其业绩汇总不正确，该怎么办呢？感激不尽!

Sub Macro1()
    Dim d As Object, dic As Object, ds As Object, arr, MyPath$, MyName$, i&, s$
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    arr = [b1].Resize(, [a1].CurrentRegion.Columns.Count - 1)
    For i = 1 To UBound(arr, 2) Step 2
        ds(arr(1, i) & "A型") = i
        ds(arr(1, i) & "B型") = i + 1
    Next
    arr = Sheets("销售人员信息").[a1].CurrentRegion
    For i = 2 To UBound(arr)
        dic(arr(i, 1)) = arr(i, 2)
    Next
    arr = Range("A4:A" & Range("A65536").End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 256)
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    Application.ScreenUpdating = False
    [a1].CurrentRegion.Offset(3, 1).ClearContents
    MyPath = ThisWorkbook.Path & "\"
    MyName = Dir(MyPath & "*.xls")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            s = "文件" & Split(MyName, ".")(0)
            With GetObject(MyPath & MyName)
                arr = .Sheets(1).[a1].CurrentRegion
                .Close False
            End With
            For i = 2 To UBound(arr)
                If dic.Exists(arr(i, 4)) And ds.Exists(s & arr(i, 2)) Then
                    If d.Exists(dic(arr(i, 4))) Then brr(d(dic(arr(i, 4))), ds(s & arr(i, 2))) = brr(d(dic(arr(i, 4))), ds(s & arr(i, 2))) + arr(i, 3)
                End If
            Next
        End If
        MyName = Dir
    Loop
    [b4].Resize(UBound(brr), ds.Count) = brr
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

zhaogang1960

这是附件：
求助.rar (27.62 KB, 下载次数: 38)

2011-2-14 21:27 上传

点击文件名下载附件

puresway

谢谢赵大哥，又够小弟学习几天了  谢谢您！