|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub lkyy()
Dim Mp$, Mf, wb As Workbook, sht As Worksheet
Set Dic = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Mp = ThisWorkbook.Path & "\"
Mf = Dir(Mp & "*.xls")
Do While Mf <> ""
If Mf <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(Mp & Mf)
For Each sht In wb.Sheets
ar = sht.UsedRange
If IsEmpty(ar) = False Then
For i = 2 To UBound(ar)
d1(ar(i, 1)) = ""
For j = 2 To UBound(ar, 2)
If ar(i, j) <> "" Then
Dic(ar(i, 1) & "|" & ar(1, j)) = Dic(ar(i, 1) & "|" & ar(1, j)) + ar(i, j)
d2(ar(1, j)) = ""
End If
Next j
Next i
End If 'IsEmpty(ar) = False
Next sht
wb.Close 0
End If 'Mf <> ThisWorkbook.Name
Mf = Dir()
Loop
Range("a1").CurrentRegion.ClearContents
[a1] = "序号"
Range("a2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
Range("b1").Resize(1, d2.Count) = d2.keys
ar = Range("a1").CurrentRegion
l = UBound(ar, 2)
For i = 2 To UBound(ar)
For j = 2 To l
If Dic.exists(ar(i, 1) & "|" & ar(1, j)) Then ar(i, j) = Dic(ar(i, 1) & "|" & ar(1, j))
Next j, i
Range("a1").CurrentRegion = ar
Cells(1, l + 1) = "合计"
For i = 2 To UBound(ar)
Cells(i, l + 1).Formula = "=sum(" & Range(Cells(i, 2), Cells(i, l)).Address(0, 0) & ")"
Next
Set Dic = Nothing
Set d1 = Nothing
Set d2 = Nothing
End Sub |
评分
-
2
查看全部评分
-
|