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

puresway · 发表于 2011-2-12 20:39

求助.rar (19.57 KB, 下载次数: 44) 各位版主，各位大虾，小弟刚接触VBA ,工作需要急需一程序，望各位版主、大虾指点，感激不尽！

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

puresway · 发表于 2011-2-12 20:41

万分感激！

puresway · 发表于 2011-2-12 21:06

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

zhaogang1960 · 发表于 2011-2-12 21:14

原帖由 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 · 发表于 2011-2-12 21:15

这是附件：

求助.rar (26.67 KB, 下载次数: 87)

puresway · 发表于 2011-2-12 21:20

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

puresway · 发表于 2011-2-12 21:43

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

zhaogang1960 · 发表于 2011-2-12 22:11

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

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

puresway · 发表于 2011-2-12 22:19

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

zhaogang1960 · 发表于 2011-2-12 22:34

原帖由 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

		自动登录	找回密码
密码			免费注册

[已解决] 求一个汇总的VBA程序（万分感谢zhaogang1960前辈）