|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
给你汇总工作簿中增加一列,填写数据来源工作簿地址i,可以方便你核对数据!
- Sub 汇总()
- Dim PathStr As String, Fil As String
- Dim Wbook As Workbook, Sht As Worksheet
- Dim dic As Object
- Dim dic02 As Object
- Dim m%, n%, k&
- Dim arr, crr, brr(1000) '直接定义一个大数组装文件
- Set dic = CreateObject("Scripting.Dictionary")
- Set dic02 = CreateObject("Scripting.Dictionary")
- With ThisWorkbook
- For m = 1 To .Worksheets.Count
- dic02(.Worksheets(m).Name) = "" '将工作表名写入字典中,方便后续查找
- Next
- End With
- PathStr = ThisWorkbook.Path & ""
- dic(PathStr) = ""
- m = 0
- Do While m < dic.Count
- arr = dic.keys
- Fil = Dir(arr(m), vbDirectory)
- Do While Fil <> ""
- If Fil <> "." And Fil <> ".." Then
- If (GetAttr(arr(m) & Fil) And vbDirectory) = vbDirectory Then
- dic(arr(m) & Fil & "") = ""
- Else
- n = n + 1
- brr(n - 1) = Mid(Fil, 1, InStrRev(Fil, ".") - 1) '提取去除文件扩展名的文件名称
- If dic02.exists(brr(n - 1)) Then '如果该工作簿名称在字典dic02中,则对应汇总。
- Set Wbook = GetObject(arr(m) & Fil) '后台打开对应的工作簿
- Set Sht = Wbook.Worksheets(1)
- With Sht 'Workbooks(Fil).Worksheets(1)对应工作簿打开好使,不打开直接引用不好使! '提取对应工作簿的第一个工作表数据
- crr = .Range("A1").CurrentRegion.Offset(1, 0) '会多引用一行空行。
- End With
- Wbook.Close False '提取数据之后必须关闭工作簿,防止下次打开你同名工作簿出错!
- With ThisWorkbook.Worksheets(brr(n - 1))
- k = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row '获取目标工作表的第一个空行行号
- .Range("A" & k).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
- .Cells(k, UBound(crr, 2) + 1).Resize(UBound(crr, 1) - 1, 1) = WorksheetFunction.Substitute(arr(m), PathStr, "") & Fil '将对应工作簿含路径的名称写入目标工作表
- End With
- End If
- End If
- End If
- Fil = Dir
- Loop
- m = m + 1
- Loop
- MsgBox "提取文件夹中对应文件数据完毕!"
- End Sub
复制代码 |
|