|
原帖由 puresway 于 2011-2-12 22:41 发表
前辈,非常感谢您!能不能再问一下,如果汇总表中的第一行文件1,文件2,文件3。。。。也是固定的位置,怎样改写代码才能实现不同文件的相应业绩对号入座呢?很想学习,谢谢前辈!
Sub Macro1()
Dim d As Object, dic As Object, ds As Object, arr, sh As Worksheet, MyPath$, MyName$, i&, s$, m%
Set sh = ActiveSheet
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, 2)) = arr(i, 1)
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)
If dic.Exists(arr(i, 1)) Then d(dic(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
m = m + 2
s = "文件" & Split(MyName, ".")(0)
sh.Cells(1, m) = s
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(s & arr(i, 2)) Then brr(d(arr(i, 4)), ds(s & arr(i, 2))) = brr(d(arr(i, 4)), ds(s & 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 |
|