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

puresway

求助.rar (19.57 KB, 下载次数: 44)

2011-2-12 20:39 上传

点击文件名下载附件

各位版主，各位大虾，小弟刚接触VBA ,工作需要急需一程序，望各位版主、大虾指点，感激不尽！

[ 本帖最后由 puresway 于 2011-2-12 23:23 编辑 ]

puresway

万分感激！

puresway

自己顶一下，怕沉了，先谢谢各位前辈了！

zhaogang1960

原帖由 puresway 于 2011-2-12 20:39 发表
871238各位版主，各位大虾，小弟刚接触VBA ,工作需要急需一程序，望各位版主、大虾指点，感激不尽！

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

zhaogang1960

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

2011-2-12 21:15 上传

点击文件名下载附件

puresway

正是需要的，谢谢zhaogang1960前辈，向您学习了，万分感激，

puresway

zhaogang1960前辈,再请教一个问题，汇总中 汇总报表A列的姓名是固定的（可能有很多人，但有业绩的是其中几个），该如何把匹配后的业绩信息对应这一列姓名进行匹配写入呢？学习了，谢谢前辈！

zhaogang1960

原帖由 puresway 于 2011-2-12 21:43 发表
zhaogang1960前辈,再请教一个问题，汇总中 汇总报表A列的姓名是固定的（可能有很多人，但有业绩的是其中几个），该如何把匹配后的业绩信息对应这一列姓名进行匹配写入呢？学习了，谢谢前辈！

没有理解，请上传附件并详细说明

puresway

都怪我没表达清楚，这是附件，请前辈看下

zhaogang1960

原帖由 puresway 于 2011-2-12 22:19 发表
都怪我没表达清楚，这是附件，请前辈看下

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