ExcelTip.Net留存知识帖 ---【注:附件之前被网盘供应商清空后,现已修复-现已修复-现已修复为本地下载!】
现在位置:首页 > 行业案例 > 质量管理 > 一份根据日品质报表生成月品质报表的样本

一份根据日品质报表生成月品质报表的样本

作者:绿色风 分类:质量管理 时间:2022-08-18 浏览:457
楼主
kevinchengcw
用于对当月的每日产品品质日报汇总生成月度报表,代码如下:
  1. Sub 报表自动汇总()
  2. Dim Dic, Dic1, Dic2, Arr, Arr1, Arr2  '定义字典及数组
  3. Dim M, N, I, A, B, C As Integer
  4. Dim Str As String
  5. Application.ScreenUpdating = False
  6. Worksheets("月报表").Rows("3:65536").Delete  '先清除现有区域内容
  7. Set Dic = CreateObject("scripting.dictionary")  '创建字典
  8. Set Dic1 = CreateObject("scripting.dictionary")
  9. Set Dic2 = CreateObject("scripting.dictionary")
  10. With Worksheets("日报表")
  11.     For M = 3 To .[b65536].End(3).Row
  12.         If .Cells(M, 2).Offset(0, 1) <> "" Then   '字典dic用来存储产品名及生产数量合计
  13.             If Dic.Exists(.Cells(M, 2).Value) Then
  14.                 Dic(.Cells(M, 2).Value) = Dic(.Cells(M, 2).Value) + .Cells(M, 2).Offset(0, 1).Value
  15.             Else
  16.                 Dic.add .Cells(M, 2).Value, .Cells(M, 2).Offset(0, 1).Value
  17.             End If
  18.         End If
  19.         If Trim(.Cells(M, 4)) <> "" Then   '字典dic1用来存储报废原因及数量,key由产品名及报废原因组成,用特定字符分隔,便于拆分
  20.             Str = .Cells(M, 2).Value & "|" & .Cells(M, 4).Value
  21.             If Dic1.Exists(Str) Then
  22.                 Dic1.Item(Str) = Dic1.Item(Str) + .Cells(M, 4).Offset(0, 1).Value
  23.             Else
  24.                 Dic1.add Str, .Cells(M, 4).Offset(0, 1).Value
  25.             End If
  26.         End If
  27.         If Trim(.Cells(M, 6)) <> "" Then   '字典dic2用来存储返修原因及数量,key由产品名及返修原因组成,用特定字符分隔,便于拆分
  28.             Str = .Cells(M, 2).Value & "|" & .Cells(M, 6).Value
  29.             If Dic2.Exists(Str) Then
  30.                 Dic2.Item(Str) = Dic2.Item(Str) + .Cells(M, 6).Offset(0, 1).Value
  31.             Else
  32.                 Dic2.add Str, .Cells(M, 6).Offset(0, 1).Value
  33.             End If
  34.         End If
  35.     Next M
  36. End With
  37. Arr = Dic.Keys  '将字典的keys赋值给数组,便于取用
  38. Arr1 = Dic1.Keys
  39. Arr2 = Dic2.Keys
  40. With Worksheets("月报表")
  41.     .Activate  '如果不激活该表会出错
  42.     N = 3  '设定数据写入的起始行值
  43.     For M = LBound(Arr) To UBound(Arr)  '循环提取产品名
  44.         If N = 3 Then  '判断是否是第一行,并给出序号取得方式
  45.             .Cells(N, 1) = 1
  46.         Else
  47.             .Cells(N, 1).Offset(-1, 0).Select
  48.             .Cells(N, 1) = ActiveCell.Value + 1
  49.         End If
  50.         .Cells(N, 2) = Arr(M)   '利用数组调出字典中相关数据并写入相应位置
  51.         .Cells(N, 3) = Dic(Arr(M))
  52.         C = 0
  53.         For A = LBound(Arr1) To UBound(Arr1)
  54.             If Split(Arr1(A), "|")(0) = Arr(M) Then
  55.                 .Cells(N + C, 4) = Split(Arr1(A), "|")(1)
  56.                 .Cells(N + C, 4).Offset(0, 1) = Dic1.Item(Arr1(A))
  57.                 .Cells(N + C, 4).Offset(0, 2) = Dic1.Item(Arr1(A)) / Dic.Item(Arr(M))
  58.                 .Cells(N + C, 4).Offset(0, 2).NumberFormatLocal = "0.00%"
  59.                 C = C + 1
  60.             End If
  61.         Next A
  62.         I = N + C
  63.         C = 0
  64.         For B = LBound(Arr2) To UBound(Arr2)
  65.             If Split(Arr2(B), "|")(0) = Arr(M) Then
  66.                 .Cells(N + C, 8) = Split(Arr2(B), "|")(1)
  67.                 .Cells(N + C, 8).Offset(0, 1) = Dic2.Item(Arr2(B))
  68.                 .Cells(N + C, 8).Offset(0, 2) = Dic2.Item(Arr2(B)) / Dic.Item(Arr(M))
  69.                 .Cells(N + C, 8).Offset(0, 2).NumberFormatLocal = "0.00%"
  70.                 C = C + 1
  71.             End If
  72.         Next B
  73.         If N + C > I Then I = N + C
  74.         .Cells(N, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(I, 6)))
  75.         .Cells(N, 7).NumberFormatLocal = "0.00%"
  76.         .Cells(N, 11) = WorksheetFunction.Sum(.Range(.Cells(N, 10), .Cells(I, 10)))
  77.         .Cells(N, 11).NumberFormatLocal = "0.00%"
  78.         Application.DisplayAlerts = False  '关闭警告信息,避免合并单元格时跳出警告窗口
  79.         For A = 1 To 11  '每个产品写入完成后判断开始单元格到最后单元格之间的空白情况并予以合并
  80.             Select Case .Cells(65536, A).End(3).Row
  81.                 Case Is < N
  82.                     .Range(.Cells(N, A), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, A)).Merge
  83.                 Case Is >= .UsedRange.SpecialCells(xlCellTypeLastCell).Row
  84.                
  85.                 Case Is >= N
  86.                     .Range(.Cells(.Cells(65536, A).End(3).Row, A), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, A)).Merge
  87.                 Case Else
  88.                
  89.             End Select
  90.         Next A
  91.         Application.DisplayAlerts = True
  92.         N = I
  93.     Next M
  94.     With .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 11))  '设置单元格对齐方式及边框线
  95.         .Borders.LineStyle = 1
  96.         .HorizontalAlignment = xlCenter
  97.         .VerticalAlignment = xlCenter
  98.     End With
  99. End With
  100. Set Dic = Nothing
  101. Set Dic1 = Nothing
  102. Set Dic2 = Nothing
  103. Application.ScreenUpdating = True
  104. End Sub


详情请参考附件
品质报表汇总.rar
2楼
ybc76
有些简单,不过作为参考资料也不错,谢谢分享
3楼
caosiheng
ddddddddddddddddddddddd
4楼
73hjj
谢谢分享
5楼
pzhds
谢谢分享
6楼
高玉甫

下载了,学习了,谢谢了,致敬了!
7楼
jackybeth
如何參考変更內容,我司產品別不同啦
8楼
高玉甫

朋友,我和您有同样的疑问,我们等待高手们的赐教吧。
9楼
mjgdxx
这还简单?没点学问写不出来的
10楼
润物细无声
学习学习,作为参考资料也不错
11楼
萤火虫-2010
谢谢无私奉献下载学习学习
12楼
yardview
学习学习,再学习
13楼
风就飘过
厉害,厉害
14楼
young.zhang
功能不错,楼主强大!
15楼
CXT360
这还简单?没点学问写不出来的
16楼
nipelove
谢谢分享
17楼
冰心8549
谢谢,下载了,
18楼
letty1985
为啥我在运行的时候出现这个呀05.jpg
 
19楼
letty1985
楼主,是复制黏贴了你的代码之后,在运行时出现的这种情况哦
20楼
kevinchengcw
代码中有指定表名的话不能简单的复制粘贴,要修改一下对应的名称
21楼
letty1985
哦,明白了
22楼
尐奻亼
很好很强大,牛
23楼
hunterzha


24楼
sharkzhou
我也下来学习
25楼
pcxangle
不太明白,先收藏了,慢慢学习
26楼
feishifan
谢谢分享
27楼
白开水的微笑
谢谢分享
28楼
eliane_lei
谢谢分享!
29楼
jxcbx
谢谢分享
30楼
KEBE
顯示宏被禁用,用不了,對VBA又不懂,不知道怎么修改,下載看看
31楼
俾啲Feel
谢谢作者的辛劳,,
32楼
nbic
收藏学习。。谢谢
33楼
亮少
谢谢分享.下载学习
34楼
chris_lian
不能修改吗
35楼
lrlxxqxa
感谢分享!
36楼
1254994937
学习学习在学习!
37楼
ywlex2010
看看,支持下
38楼
odoobo
有用没用,先看了再说

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素, 经与ExcelTip.Net站长Apolloh商议并征得其同意, 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示, 供有需要的人士查询使用,也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议, 可与本人沟通提出,或于本站点留言,我们会尽快处理。 在此,感谢ExcelTip.Net站长Apolloh的支持,感谢本站点所有人**绿色风(QQ:79664738)**的支持与奉献,特此鸣谢!
------本人网名**KevinChengCW(QQ:1210618015)**原ExcelTip.Net总版主之一

评论列表
sitemap