如何用VBA汇总班表

DavideLamb · 发表于 2023-4-12 10:37

如何用VBA汇总班表，将每周班表汇总为一个月

ykcbf1100 · 发表于 2023-4-12 11:10

附件从参考。。。

注意：总表中汇总

chxw68 · 发表于 2023-4-12 11:14

Sub test()
Dim r%, i%
Dim arr, brr
Dim ws As Worksheet
Dim reg As New RegExp
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With reg
.Global = False
.Pattern = "^\d{1,2}\.\d{1,2}-\d{1,2}\.\d{1,2}$"
End With
For Each ws In Worksheets
If reg.test(ws.Name) Then
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
d(ws.Name) = .Range("a2").Resize(r - 1, c)
End With
End If
Next
n = 1
For Each aa In d.keys
arr = d(aa)
For j = 2 To UBound(arr, 2)
n = n + 1
d2(arr(1, j)) = n
Next
Next
ls = d2.Count + 1
For Each aa In d.keys
arr = d(aa)
For i = 3 To UBound(arr)
If Not d1.exists(arr(i, 1)) Then
ReDim brr(1 To ls)
brr(1) = arr(i, 1)
Else
brr = d1(arr(i, 1))
End If
For j = 2 To UBound(arr, 2)
n = d2(arr(1, j))
brr(n) = arr(i, j)
Next
d1(arr(i, 1)) = brr
Next
Next
With Worksheets("汇总")
.Cells.Clear
.Range("a1") = "姓名"
n = 1
For Each aa In d2.keys
n = n + 1
With .Cells(1, n)
.Value = aa
.NumberFormatLocal = "m/d"
End With
With .Cells(2, n)
.Value = Application.Weekday(aa)
.NumberFormatLocal = "[DBnum1]"
End With
Next
arr = Application.Transpose(Application.Transpose(d1.items))
.Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
For i = 1 To UBound(arr)
For j = 2 To UBound(arr, 2)
If arr(i, j) = "正" Then
.Cells(i + 2, j).Font.ColorIndex = 3
End If
Next
Next
With .Range("a1").Resize(2 + UBound(arr), ls)
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2023-4-12 11:15

详见附件。

		自动登录	找回密码
密码			免费注册

[求助] 如何用VBA汇总班表

评分