|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 汇总数据()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("a3:p" & r + 2).Borders.LineStyle = 0
.Range("a3:p" & r + 2) = Empty
ar = .Range("a1:p10000")
For j = 3 To UBound(ar, 2) - 2 Step 3
If Trim(ar(1, j)) <> "" Then
d(Trim(ar(1, j))) = j
End If
Next j
k = 2
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
br = wb.Worksheets(1).[a1].CurrentRegion
mc = Trim(Split(wb.Name, ".")(0))
y = d(mc)
wb.Close False
For i = 2 To UBound(br)
If Trim(br(i, 2)) <> "" Then
t = d(Trim(br(i, 2)))
If t = "" Then
k = k + 1
d(Trim(br(i, 2))) = k
t = k
ar(k, 1) = br(i, 2)
ar(k, 2) = br(i, 3)
End If
If y <> "" Then
ar(t, y) = ar(t, y) + br(i, 4)
ar(t, y + 1) = br(i, 5)
ar(t, y + 2) = ar(t, y + 2) + br(i, 6)
End If
End If
Next i
End If
f = Dir
Loop
For i = 3 To k
n = 0
ReDim rr(1 To 4, 1 To 1)
For j = 4 To UBound(ar, 2) - 2 Step 3
If IsNumeric(ar(i, j)) Then
n = n + 1
rr(n, 1) = ar(i, j)
End If
Next j
zd = Application.Max(Application.Index(rr, 0, 1))
zx = Application.Min(Application.Index(rr, 0, 1))
ar(i, 15) = zd - zx
Next i
.[a1].Resize(k, UBound(ar, 2)) = ar
.[a1].Resize(k, UBound(ar, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
2
查看全部评分
-
|