求助，从一个文件夹中若干个同一模板格式的excle文件中提取几个数据到一个新的excle中

hst222

求助，从一个文件夹中若干个同一模板格式的excle文件中提取几个数据到一个新的excle中进行汇总登记，而且是每次往文件夹中新增一个excle，这个汇总的excle中就自动出现所提取的数据，请看附件里面模板的颜色区域是需要提取的数据，另外一个是汇总文件，请哪位大神帮帮忙！感激不尽！

jsxjd

参考：

http://club.excelhome.net/forum. ... 741&pid=7946436

TomingTang

1. Sub L()
   
2.     Dim Mypath$, Myname$, str$, sht As Worksheet, i%, Arr(1 To 10000, 1 To 15), drow%, drow1%, Brr, k%, j%, d, mmax%
   
3.     mmax = 1: i = 1
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     On Error Resume Next
   
6.     sht = ThisWorkbook.Worksheets("sheet1")
   
7.     Mypath = ThisWorkbook.Path & ""
   
8.     Myname = Dir(Mypath & "*.xls")
   
9.     Application.ScreenUpdating = False
   
10. 
    
11.     Do While Myname <> ""
    
12.         If Myname <> ThisWorkbook.Name Then
    
13.           '  MsgBox Myname
    
14.             With GetObject(Mypath & Myname)
    
15.                 With .Sheets(1)
    
16.                     Arr(i, 2) = .Cells(4, 6).Value: Arr(i, 3) = .Cells(7, 6): Arr(i, 4) = .Cells(5, 6)
    
17.                     Arr(i, 5) = .Cells(9, 6): Arr(i, 6) = .Cells(11, 6): Arr(i, 7) = .Cells(13, 3): Arr(i, 1) = i
    
18.                     i = i + 1
    
19.                     mmax = i
    
20.                 End With
    
21.                 .Close False
    
22.             End With
    
23.         End If
    
24.         Myname = Dir
    
25.     Loop
    
26.     With ThisWorkbook.Worksheets("sheet1")
    
27.         drow1 = .[a65526].End(3).Row
    
28.         Brr = .Range("a2:g" & drow1)
    
29.         For j = 1 To mmax
    
30.             d(Arr(j, 2)) = j
    
31.         Next
    
32.         For j = 1 To UBound(Brr)
    
33.             Debug.Print j & "  " & "brr(j,2)=   " & Brr(j, 2) & "        " & d(Brr(j, 2))
    
34.             For k = 3 To UBound(Brr, 2)
    
35.                 Brr(j, k) = Arr(d(Brr(j, 2)), k)
    
36.             Next
    
37.         Next
    
38.         .Cells(2, 1).Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    
39.     End With
    
40.     Application.ScreenUpdating = True
    
41. End Sub
    

复制代码