|
- Dim w(1 To 10000), s%
- Sub Macro1()
- Dim arr, brr, crr, d, wb As Workbook, i&, j&, k%
- Set d = CreateObject("scripting.dictionary")
- arr = ActiveSheet.UsedRange
- s = 0
- zdir ThisWorkbook.Path & "\2013年腾冲2标段竣工资料"
- ReDim brr(1 To UBound(arr) - 2, 1 To s + 5)
- Application.ScreenUpdating = False
- brr(1, s + 1) = "合计"
- brr(1, s + 2) = "出库数量"
- brr(1, s + 3) = "单价"
- brr(1, s + 4) = "出库-合计"
- brr(1, s + 5) = "金额"
- For i = 1 To s
- Set wb = GetObject(w(i))
- crr = wb.Sheets("单项工程材料").UsedRange
- wb.Close 0
- x = Split(w(i), "")
- brr(1, i) = Replace(x(UBound(x)), ".xls*", "")
- For j = 4 To UBound(crr)
- brr(j - 2, i) = crr(j, 10)
- brr(j - 2, s + 1) = brr(j - 2, s + 1) + crr(j, 10)
- Next
- Next
- Set wb = GetObject(ThisWorkbook.Path & "\仓库出库结算汇总.xls")
- crr = wb.Sheets(1).Range("a1").CurrentRegion
- For i = 6 To UBound(crr)
- zf = crr(i, 2) & "," & crr(i, 3) & "," & crr(i, 4)
- d(zf) = i
- Next
- For i = 4 To UBound(arr)
- zf = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
- If d.Exists(zf) Then
- n = d(zf)
- brr(i - 2, s + 2) = crr(n, 5)
- brr(i - 2, s + 3) = crr(n, 6)
- brr(i - 2, s + 4) = brr(i - 2, s + 2) - brr(i - 2, s + 1)
- brr(i - 2, s + 5) = brr(i - 2, s + 4) * brr(i - 2, s + 3)
- End If
- Next
- Range("e3").Resize(UBound(brr), UBound(brr, 2)) = brr
- Application.ScreenUpdating = True
- End Sub
- Sub zdir(p)
- Dim fs As New FileSystemObject
- For Each f In fs.GetFolder(p).Files
- If f Like "*.xls*" Then s = s + 1: w(s) = f
- Next
- For Each m In fs.GetFolder(p).SubFolders
- zdir m
- Next
- End Sub
复制代码 |
|