楼主
kevinchengcw |
用于对当月的每日产品品质日报汇总生成月度报表，代码如下：
- Sub 报表自动汇总()
- Dim Dic, Dic1, Dic2, Arr, Arr1, Arr2 '定义字典及数组
- Dim M, N, I, A, B, C As Integer
- Dim Str As String
- Application.ScreenUpdating = False
- Worksheets("月报表").Rows("3:65536").Delete '先清除现有区域内容
- Set Dic = CreateObject("scripting.dictionary") '创建字典
- Set Dic1 = CreateObject("scripting.dictionary")
- Set Dic2 = CreateObject("scripting.dictionary")
- With Worksheets("日报表")
- For M = 3 To .[b65536].End(3).Row
- If .Cells(M, 2).Offset(0, 1) <> "" Then '字典dic用来存储产品名及生产数量合计
- If Dic.Exists(.Cells(M, 2).Value) Then
- Dic(.Cells(M, 2).Value) = Dic(.Cells(M, 2).Value) + .Cells(M, 2).Offset(0, 1).Value
- Else
- Dic.add .Cells(M, 2).Value, .Cells(M, 2).Offset(0, 1).Value
- End If
- End If
- If Trim(.Cells(M, 4)) <> "" Then '字典dic1用来存储报废原因及数量，key由产品名及报废原因组成，用特定字符分隔，便于拆分
- Str = .Cells(M, 2).Value & "|" & .Cells(M, 4).Value
- If Dic1.Exists(Str) Then
- Dic1.Item(Str) = Dic1.Item(Str) + .Cells(M, 4).Offset(0, 1).Value
- Else
- Dic1.add Str, .Cells(M, 4).Offset(0, 1).Value
- End If
- End If
- If Trim(.Cells(M, 6)) <> "" Then '字典dic2用来存储返修原因及数量，key由产品名及返修原因组成，用特定字符分隔，便于拆分
- Str = .Cells(M, 2).Value & "|" & .Cells(M, 6).Value
- If Dic2.Exists(Str) Then
- Dic2.Item(Str) = Dic2.Item(Str) + .Cells(M, 6).Offset(0, 1).Value
- Else
- Dic2.add Str, .Cells(M, 6).Offset(0, 1).Value
- End If
- End If
- Next M
- End With
- Arr = Dic.Keys '将字典的keys赋值给数组，便于取用
- Arr1 = Dic1.Keys
- Arr2 = Dic2.Keys
- With Worksheets("月报表")
- .Activate '如果不激活该表会出错
- N = 3 '设定数据写入的起始行值
- For M = LBound(Arr) To UBound(Arr) '循环提取产品名
- If N = 3 Then '判断是否是第一行，并给出序号取得方式
- .Cells(N, 1) = 1
- Else
- .Cells(N, 1).Offset(-1, 0).Select
- .Cells(N, 1) = ActiveCell.Value + 1
- End If
- .Cells(N, 2) = Arr(M) '利用数组调出字典中相关数据并写入相应位置
- .Cells(N, 3) = Dic(Arr(M))
- C = 0
- For A = LBound(Arr1) To UBound(Arr1)
- If Split(Arr1(A), "|")(0) = Arr(M) Then
- .Cells(N + C, 4) = Split(Arr1(A), "|")(1)
- .Cells(N + C, 4).Offset(0, 1) = Dic1.Item(Arr1(A))
- .Cells(N + C, 4).Offset(0, 2) = Dic1.Item(Arr1(A)) / Dic.Item(Arr(M))
- .Cells(N + C, 4).Offset(0, 2).NumberFormatLocal = "0.00%"
- C = C + 1
- End If
- Next A
- I = N + C
- C = 0
- For B = LBound(Arr2) To UBound(Arr2)
- If Split(Arr2(B), "|")(0) = Arr(M) Then
- .Cells(N + C, 8) = Split(Arr2(B), "|")(1)
- .Cells(N + C, 8).Offset(0, 1) = Dic2.Item(Arr2(B))
- .Cells(N + C, 8).Offset(0, 2) = Dic2.Item(Arr2(B)) / Dic.Item(Arr(M))
- .Cells(N + C, 8).Offset(0, 2).NumberFormatLocal = "0.00%"
- C = C + 1
- End If
- Next B
- If N + C > I Then I = N + C
- .Cells(N, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(I, 6)))
- .Cells(N, 7).NumberFormatLocal = "0.00%"
- .Cells(N, 11) = WorksheetFunction.Sum(.Range(.Cells(N, 10), .Cells(I, 10)))
- .Cells(N, 11).NumberFormatLocal = "0.00%"
- Application.DisplayAlerts = False '关闭警告信息，避免合并单元格时跳出警告窗口
- For A = 1 To 11 '每个产品写入完成后判断开始单元格到最后单元格之间的空白情况并予以合并
- Select Case .Cells(65536, A).End(3).Row
- Case Is < N
- .Range(.Cells(N, A), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, A)).Merge
- Case Is >= .UsedRange.SpecialCells(xlCellTypeLastCell).Row
-
- Case Is >= N
- .Range(.Cells(.Cells(65536, A).End(3).Row, A), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, A)).Merge
- Case Else
-
- End Select
- Next A
- Application.DisplayAlerts = True
- N = I
- Next M
- With .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 11)) '设置单元格对齐方式及边框线
- .Borders.LineStyle = 1
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- End With
- Set Dic = Nothing
- Set Dic1 = Nothing
- Set Dic2 = Nothing
- Application.ScreenUpdating = True
- End Sub
详情请参考附件
 品质报表汇总.rar
|
谢谢分享 
厉害，厉害 
