VBA多表汇总

小表弟@@

大佬！求助！ 将多个文件里面的工作表中的指定sheet里面的内容，汇总到一个sheet里面！

FOB_FN_L

http://club.excelhome.net/forum. ... 6orderby%3Dlastpost     这里那么多，总有适合你的吧

盼哥

1.     Dim i&, sc&
   
2. Sub SumAllexFile()
   
3.     Dim fileArr, sBook As Workbook, endRow&
   
4.     With ThisWorkbook.ActiveSheet.UsedRange
   
5.         If .Rows.Count > 1 Then
   
6.             .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete   '清除数据
   
7.         End If
   
8.     End With
   
9. 
   
10.     endRow = 1
    
11.     Call getFileList(ThisWorkbook.Path, fileArr, "*.xls*", True)            '获取所有xls文件列表
    
12.     For i = 1 To UBound(fileArr)
    
13.         If fileArr(i) <> ThisWorkbook.Path & "" & ThisWorkbook.Name Then
    
14.             Set sBook = Workbooks.Open(fileArr(i))                          '遍历所有薄
    
15.             With sBook
    
16.               For sc = 1 To 2                                               '遍历所有表
    
17.                 With .Sheets(sc).UsedRange
    
18.                     .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
    
19.                         .Copy ThisWorkbook.ActiveSheet.Cells(endRow + 1, 1)     '复制数据
    
20.                 End With
    
21.                 endRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    
22.               Next sc
    
23.               .Close False
    
24.             End With
    
25.         End If
    
26.     Next i
    
27.     ThisWorkbook.ActiveSheet.Columns.AutoFit
    
28. End Sub
    
29. Sub getFileList(p$, fileArr, ftype$, ctnSub As Boolean)
    
30.     If ctnSub Then
    
31.         Call getSubDirFileList(p, fileArr, ftype)
    
32.     Else
    
33.         Call getCurDirFileList(p, fileArr, ftype)
    
34.     End If
    
35. End Sub
    
36. Sub getCurDirFileList(p$, fileArr, ftype$)
    
37.     Dim fullName$, fileName$
    
38.     Dim fileListColl As New Collection
    
39.     fileName = Dir(p & "" & ftype)
    
40.     Do While fileName <> ""
    
41.         fileListColl.Add p & "" & fileName
    
42.         fileName = Dir
    
43.     Loop
    
44.     Call Collection2Arr(fileListColl, fileArr) '转换集合为数组
    
45. End Sub
    
46. Sub getSubDirFileList(sFolderPath As String, fileArr, ftype$)
    
47.     On Error Resume Next
    
48.     Dim f As String
    
49.     Dim file() As String
    
50.     Dim i, k, x
    
51.     x = 1
    
52.     i = 1
    
53.     k = 1
    
54.     ReDim file(1 To i)
    
55.     file(1) = sFolderPath & ""
    
56.     '-- 获得所有子目录
    
57.     Do Until i > k
    
58.         f = Dir(file(i), vbDirectory)
    
59.         Do Until f = ""
    
60.             If InStr(f, ".") = 0 Then
    
61.                 k = k + 1
    
62.                 ReDim Preserve file(1 To k)
    
63.                 file(k) = file(i) & f & ""
    
64.             End If
    
65.             f = Dir
    
66.         Loop
    
67.         i = i + 1
    
68.     Loop
    
69.     '-- 获得所有子目录下的所有文件
    
70.     Dim fileListColl As New Collection
    
71.     For i = 1 To k
    
72.         f = Dir(file(i) & ftype)
    
73.         Do Until f = ""
    
74.             fileListColl.Add (file(i) & f)
    
75.             x = x + 1
    
76.             f = Dir
    
77.         Loop
    
78.     Next
    
79.     Call Collection2Arr(fileListColl, fileArr)  '转换集合为数组
    
80. End Sub
    
81. Sub Collection2Arr(coln, arr)
    
82.     ReDim arr(1 To coln.Count)
    
83.     For i = 1 To coln.Count
    
84.         arr(i) = coln.Item(i)
    
85.     Next
    
86. End Sub

复制代码

excelvlookup

好久没写过这么有意思的代码了，附件就不上传了
Sub AA()
    a = ThisWorkbook.Path
    Dim ar(1 To 100)
    b = Dir(a & "\*", 16)
    n = 0
    While b <> ""
        If GetAttr(a & "\" & b) = vbDirectory And b <> "." And b <> ".." Then
            n = n + 1
            ar(n) = a & "\" & b
        End If
        b = Dir
    Wend
    ReDim br(1 To n * 100)
    Application.ScreenUpdating = False
    For i = 1 To n
        a1 = Dir(ar(i) & "\*.xls*")
        While a1 <> ""
            Set wb = GetObject(ar(i) & "\" & a1)
            For Each sh In wb.Sheets
                If InStr(sh.Name, "不需要") = 0 Then
                    s = s + 1
                    rw = sh.Cells(Rows.Count, 2).End(3).Row
                    If s = 1 Then brr = sh.Range("a1:i1")
                    br(s) = sh.Range("a2:i" & rw)
                End If
            Next
            wb.Close 0
            a1 = Dir
        Wend
    Next
   
    Sheet1.Range("a1").Resize(, 9) = brr
    x = 2
    For i = 1 To s
        Sheet1.Range("a" & x).Resize(UBound(br(i)), 9) = br(i)
        x = x + UBound(br(i))
    Next
    Application.ScreenUpdating = True
End Sub