|
多表汇总。。。- Sub ykcbf() '//2024.12.31
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("Scripting.Dictionary")
- Set Sh = ThisWorkbook.Sheets("统计")
- ReDim brr(1 To 10000, 1 To 100)
- bt = [{"基础分","扣分","考核分"}]
- On Error Resume Next
- M = 2: n = 3
- For Each sht In Sheets
- If sht.Name <> Sh.Name Then
- arr = sht.UsedRange
- For j = 1 To 3
- brr(1, j) = arr(1, j)
- Next
- For i = 3 To UBound(arr)
- s = arr(i, 1)
- If Not d.exists(s) Then
- M = M + 1
- d(s) = M
- brr(M, 1) = arr(i, 1)
- brr(M, 2) = arr(i, 2)
- brr(M, 3) = arr(i, 3)
- End If
- r = d(arr(i, 1))
- s = arr(1, 4)
- If Not d.exists(s) Then
- n = n + 3
- d(s) = n
- brr(1, n - 2) = s
- For x = 1 To UBound(bt)
- brr(2, n - 3 + x) = bt(x)
- Next
- End If
- c = d(arr(1, 4))
- brr(r, c - 2) = brr(r, c - 2) + arr(i, 4) + arr(i, 5) + arr(i, 6)
- brr(r, c - 1) = brr(r, c - 1) + arr(i, 7)
- brr(r, c) = brr(r, c) + arr(i, 8)
- Next
- End If
- Next
- With Sh
- .UsedRange.Clear
- .[a1].Resize(2, n).Interior.Color = 49407
- .[a3].Resize(M - 2, 1).Interior.Color = 5296274
- With .[a1].Resize(M, n)
- .Value = brr
- .Borders.LineStyle = 1
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- With .Font
- .Name = "微软雅黑"
- .Size = 11
- End With
- End With
- For j = 1 To 3
- .Cells(1, j).Resize(2).Merge
- Next
- For j = 4 To n Step 3
- .Cells(1, j).Resize(, 3).Merge
- Next
- ActiveWindow.DisplayZeros = False
- End With
- Set d = Nothing
- Application.ScreenUpdating = True
- MsgBox "OK!"
- End Sub
复制代码
|
评分
-
2
查看全部评分
-
|