多表格数据汇总-急急急，在线等

emmahhm

多个表格的数据要汇总到一个表格里，详细如附件，还请高手帮帮忙，表格有1000+，急急急，在线等

emmahhm

高手高手，帮帮忙吧，跪求

emmahhm

高手呢？在哪里啊

ppp710715

1. Sub yy()
   
2. Application.ScreenUpdating = False
   
3. Dim aw As Workbook, k%, rg As Range, s$, r$
   
4. Dim arr, m%, rw%
   
5.   Set aw = ThisWorkbook
   
6.   aw.Sheets("汇总表").[A:c] = ""
   
7.   aw.Sheets("汇总表").Range(Cells(1, 1), Cells(1, 3)) = Array("表名", "名字1", "名字2")
   
8.    
   
9.       '以下遍历文件，提取各单数据
   
10.   p = aw.Path & ""
    
11.   f = Dir(p & "*.xls")
    
12.   Do While f <> ""
    
13.     If f <> ThisWorkbook.Name Then
    
14.         Set wk = GetObject(p & f)
    
15.         wk.Sheets("4").Activate
    
16.         Set rg = wk.Sheets("4").[a:a].Find("名字1")
    
17.         k = rg.CurrentRegion.Rows.Count
    
18.         arr = rg.Offset(1, 1).Resize(k - rg.Row + 1, 2)
    
19.         rw = aw.Sheets("汇总表").[b65536].End(3).Row
    
20.         r = wk.Name
    
21.         w = InStr(wk.Name, ".")
    
22.         s = Left(wk.Name, w - 1)
    
23.         MsgBox s
    
24.         aw.Sheets("汇总表").Range("a" & rw + 1 & ":a" & UBound(arr) + rw).Value = s
    
25.         aw.Sheets("汇总表").Range("b" & rw + 1).Resize(UBound(arr), 2) = arr
    
26.         wk.Close False
    
27.      End If
    
28.       f = Dir
    
29.   Loop
    
30.       m = aw.Sheets("汇总表").[b65536].End(3).Row
    
31.         
    
32.    With aw.Sheets("汇总表").Range(Cells(1, 1), Cells(m, 3)).Borders
    
33.      .LineStyle = xlContinuous
    
34.      .ColorIndex = 0
    
35.      .TintAndShade = 0
    
36.      .Weight = xlThin
    
37.    End With
    
38.    aw.Sheets("汇总表").[A:c].Columns.AutoFit
    
39.    
    
40. Application.ScreenUpdating = True
    
41. MsgBox "汇总完毕！"
    
42. End Sub 多表格数据汇总-急急急.rar (230.74 KB, 下载次数: 11)
    2017-10-23 09:30 上传

    点击文件名下载附件

复制代码