|
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr()
ReDim arr(1 To 10000, 1 To 15)
arr(1, 1) = "序号": arr(1, 2) = "姓名": arr(1, 3) = "学号"
f = Dir(ThisWorkbook.Path & "\*.xls*")
k = 1: y = 3
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
y = y + 1
ar = wb.Worksheets(1).[a1].CurrentRegion
arr(1, y) = ar(1, 4)
d(Trim(arr(1, y))) = y
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
t = d(Trim(ar(i, 3)))
If t = "" Then
k = k + 1
d(Trim(ar(i, 3))) = k
t = k
arr(k, 1) = k
arr(k, 2) = ar(i, 2)
arr(k, 3) = ar(i, 3)
End If
arr(t, y) = ar(i, 4)
End If
Next i
wb.Close False
End If
f = Dir
Loop
With Sheet1
.[a1].CurrentRegion.Borders.LineStyle = 0
.[a1].CurrentRegion = Empty
.[a1].Resize(k, y) = arr
.[a1].Resize(k, y).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|