|
多文件多表数据汇总- Sub ykcbf() '//2025.1.9
- Set fso = CreateObject("scripting.filesystemobject")
- Set d = CreateObject("Scripting.Dictionary")
- Application.ScreenUpdating = False
- Set sh = ThisWorkbook.Sheets(1)
- p = ThisWorkbook.Path & ""
- ReDim brr(1 To 1000, 1 To 4)
- Dim tm: tm = Timer
- For Each f In fso.GetFolder(p).Files
- If LCase$(f.Name) Like "*.xls*" Then
- If InStr(f.Name, ThisWorkbook.Name) = 0 Then
- fn = fso.GetBaseName(f)
- Set wb = Workbooks.Open(f, 0)
- s = wb.Sheets("会审信息").[c2].Value
- If Not d.exists(s) Then
- m = m + 1
- d(s) = m
- brr(m, 1) = s
- With wb.Sheets("结算材料")
- If .FilterMode = True Then .ShowAllData
- r1 = .UsedRange.Find("主设备合计").Row
- r2 = .UsedRange.Find("国内设备合计").Row
- brr(m, 2) = .Cells(r1, 8).Value
- brr(m, 3) = .Cells(r2, 8).Value
- End With
- With wb.Sheets("B2")
- If .FilterMode = True Then .ShowAllData
- r1 = .UsedRange.Find("建安工程费(除税价)").Row
- brr(m, 4) = .Cells(r1, 5).Value
- End With
- End If
- wb.Close False
- End If
- End If
- Next f
- With sh
- .UsedRange.Offset(1).ClearContents
- .[a2].Resize(m, 4) = brr
- .[a2].Resize(m, 4).Borders.LineStyle = 1
- End With
- Set d = Nothing
- Application.ScreenUpdating = True
- MsgBox "共用时:" & Format(Timer - tm) & "秒!"
- End Sub
复制代码
汇总
|
|