|
|
- Sub qs()
- ' 关闭警告提示，以便在执行宏时不弹出警告对话框
- Application.DisplayAlerts = False
-
- ' 定义和初始化变量
- Dim arr, i As Long, c As Long, cc As Long, m As Long, rw As Long
- Dim s As String, s2 As String, s3 As String
- Dim dic As Object, d2 As Object, d3 As Object
- Set dic = CreateObject("scripting.dictionary") ' 存储所有数据的字典
- Set d2 = CreateObject("scripting.dictionary") ' 存储每个类别的数据
- Set d3 = CreateObject("scripting.dictionary") ' 存储所有唯一的姓名
-
- ' 从 Sheet4 获取数据区域
- With Sheet4
- arr = .Range("a1").CurrentRegion.Value ' 获取数据区域的值
-
- ' 遍历数据区域的特定列
- For c = 4 To 5
- s = arr(1, c) ' 当前类别
-
- ' 遍历数据区域的每一行
- For i = 2 To UBound(arr)
- s2 = arr(i, 2) ' 姓名
- s3 = arr(i, 3) ' 项目
-
- ' 构建嵌套字典，存储每个人的每个项目的数据
- If Not dic.Exists(s) Then Set dic(s) = CreateObject("scripting.dictionary")
- If Not dic(s).Exists(s2) Then Set dic(s)(s2) = CreateObject("scripting.dictionary")
- dic(s)(s2)(s3) = arr(i, c)
-
- ' 如果单元格不为空，则记录数据
- If Not IsEmpty(arr(i, c)) Then
- If Not d2.Exists(s) Then Set d2(s) = CreateObject("scripting.dictionary")
- d2(s)(s3) = ""
- End If
-
- ' 记录所有唯一的姓名
- d3(s2) = ""
- Next i
- Next c
-
- ' 初始化汇总数组
- ReDim hrr(1 To 2, 1 To 13)
- hrr(1, 1) = "序号": hrr(1, 2) = "姓名": hrr(1, 13) = "合计"
- cc = 2
-
- ' 构建汇总数据的表头
- For Each dk2 In d2.Keys
- For Each dk3 In d2(dk2).Keys
- cc = cc + 1
- hrr(1, cc) = dk2
- hrr(2, cc) = dk3
- Next
- cc = cc + 1
- hrr(1, cc) = "小计": hrr(2, cc) = "小计"
- Next dk2
-
- ' 根据字典 d3 的计数初始化数组 brr
- rw = d3.Count
- ReDim brr(1 To rw, 1 To UBound(hrr, 2))
-
- ' 填充数组 brr
- m = 0 ' 初始化行计数器
- For Each k In d3.Keys
- m = m + 1
- brr(m, 1) = "'" & m ' 序号
- brr(m, 2) = k ' 姓名
- Next
-
- ' 计算每个人的每个项目的数据
- For i = 1 To m
- For j = 3 To 11
- If hrr(1, j) <> "小计" Then
- brr(i, j) = dic(hrr(1, j))(brr(i, 2))(hrr(2, j))
- End If
- Next
- ' 计算两列的总和
- sm1 = 0: sm2 = 0
- For col = 3 To 7
- sm1 = sm1 + brr(i, col)
- Next
- For col2 = 9 To 11
- sm2 = sm2 + brr(i, col2)
- Next
- brr(i, 8) = sm1 ' 第一列总和
- brr(i, 12) = sm2 ' 第二列总和
- brr(i, 13) = sm1 + sm2 ' 合计
- Next i
-
- ' 计算合计
- ReDim Err(1 To 1, 1 To 13)
- Err(1, 2) = "合计"
- For cl = 3 To 13
- Err(1, cl) = Application.WorksheetFunction.Sum(Application.Index(brr, , cl))
- Next
-
- ' 清除旧数据并填充新数据
- .Range("h12").Resize(10000, 13).Clear
- .Range("h12").Resize(2, 13).Value = hrr
- .Range("h14").Resize(m, 13).Value = brr
- .Range("h14").Offset(m).Resize(1, 13).Value = Err
-
- ' 设置边框和对齐方式
- With .Range("h12").CurrentRegion
- .Borders.LineStyle = 1
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .NumberFormat = "0.00"
- End With
-
- ' 合并单元格
- .Range("h12:h13").Merge
- .Range("i12:i13").Merge
- .Range("t12:t13").Merge
- .Range("j12:o12").Merge
- .Range("p12:s12").Merge
- End With
-
- ' 清理对象
- Set dic = Nothing: Set d2 = Nothing: Set d3 = Nothing
- ' 恢复警告提示
- Application.DisplayAlerts = True
- End Sub
|
评分
-
1
查看全部评分
-
|
楼主: ddz79101
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-9-17 15:29
楼主
发表于 2024-9-19 12:51
