|
Sub UpdateSummary() '//2023.12.15
Dim fso As Object
Dim d As Object
Dim sh As Worksheet
Dim p As String
Dim f As Object
Dim Wb As Workbook
Dim r As Long
Dim c1 As Long, c2 As Long
Dim arr As Variant
Dim fn As String
Dim i As Long
Dim s As String, t As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("汇总表")
p = ThisWorkbook.Path & "\得分表"
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = fso.GetBaseName(f)
Set Wb = Workbooks.Open(f, 0)
With Wb.Sheets(1)
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c1 = .Rows(1).Find("得分", , , , , 1).Column
c2 = .Rows(1).Find("金额", , , , , 1).Column
arr = .Range("A1", .Cells(r, c2)).Value
End With
Wb.Close False
For i = 2 To UBound(arr)
s = arr(i, 1)
If Not d.Exists(s) Then
d(s) = Array(s, arr(i, c1), arr(i, c2))
Else
t = d(s)
t(1) = t(1) + arr(i, c1)
t(2) = t(2) + arr(i, c2)
d(s) = t
End If
Next
End If
End If
Next f
With sh
.UsedRange.Offset(1).Clear
With .Range("A2").Resize(d.Count, 3)
.Value = Application.Rept(d.Items, 1)
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("B2").Resize(d.Count, 2)
.HorizontalAlignment = xlRight
End With
End With
Application.ScreenUpdating = True
Set fso = Nothing
Set d = Nothing
Set sh = Nothing
Set Wb = Nothing
MsgBox "OK!"
End Sub
|
|