|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Dim i&, sc&
- Sub SumAllexFile()
- Dim fileArr, sBook As Workbook, endRow&
- With ThisWorkbook.ActiveSheet.UsedRange
- If .Rows.Count > 1 Then
- .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete '清除数据
- End If
- End With
- endRow = 1
- Call getFileList(ThisWorkbook.Path, fileArr, "*.xls*", True) '获取所有xls文件列表
- For i = 1 To UBound(fileArr)
- If fileArr(i) <> ThisWorkbook.Path & "" & ThisWorkbook.Name Then
- Set sBook = Workbooks.Open(fileArr(i)) '遍历所有薄
- With sBook
- For sc = 1 To 2 '遍历所有表
- With .Sheets(sc).UsedRange
- .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
- .Copy ThisWorkbook.ActiveSheet.Cells(endRow + 1, 1) '复制数据
- End With
- endRow = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
- Next sc
- .Close False
- End With
- End If
- Next i
- ThisWorkbook.ActiveSheet.Columns.AutoFit
- End Sub
- Sub getFileList(p$, fileArr, ftype$, ctnSub As Boolean)
- If ctnSub Then
- Call getSubDirFileList(p, fileArr, ftype)
- Else
- Call getCurDirFileList(p, fileArr, ftype)
- End If
- End Sub
- Sub getCurDirFileList(p$, fileArr, ftype$)
- Dim fullName$, fileName$
- Dim fileListColl As New Collection
- fileName = Dir(p & "" & ftype)
- Do While fileName <> ""
- fileListColl.Add p & "" & fileName
- fileName = Dir
- Loop
- Call Collection2Arr(fileListColl, fileArr) '转换集合为数组
- End Sub
- Sub getSubDirFileList(sFolderPath As String, fileArr, ftype$)
- On Error Resume Next
- Dim f As String
- Dim file() As String
- Dim i, k, x
- x = 1
- i = 1
- k = 1
- ReDim file(1 To i)
- file(1) = sFolderPath & ""
- '-- 获得所有子目录
- Do Until i > k
- f = Dir(file(i), vbDirectory)
- Do Until f = ""
- If InStr(f, ".") = 0 Then
- k = k + 1
- ReDim Preserve file(1 To k)
- file(k) = file(i) & f & ""
- End If
- f = Dir
- Loop
- i = i + 1
- Loop
- '-- 获得所有子目录下的所有文件
- Dim fileListColl As New Collection
- For i = 1 To k
- f = Dir(file(i) & ftype)
- Do Until f = ""
- fileListColl.Add (file(i) & f)
- x = x + 1
- f = Dir
- Loop
- Next
- Call Collection2Arr(fileListColl, fileArr) '转换集合为数组
- End Sub
- Sub Collection2Arr(coln, arr)
- ReDim arr(1 To coln.Count)
- For i = 1 To coln.Count
- arr(i) = coln.Item(i)
- Next
- End Sub
复制代码 |
|