导出另存新表的时候按照条件求和

№①June

各位老师，本人VBA小白，工作中有张表根据自己的需要套用论坛上其他老师作品的代码后，有点小改动，求老师帮忙修改下，要求是：在工序查询表中按导出工序按钮后，导出查询后的数据按照工序导出表的模板另存新表，这步已经完成，主要是增加工序导出表表头按照等级条件求和，另存的时候用VBA代码写入表中，谢谢老师。

ykcbf1100

附件下载后无法打开。

№①June

ykcbf1100 发表于 2024-11-15 09:28
附件下载后无法打开。

不好意思老师，估计是版本的问题，我重新上传

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.15
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("工序查询")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a9].Resize(r - 8, 8)
   
7.     End With
   
8.     ReDim brr(1 To r, 1 To 4)
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 6)
    
11.         If Not d.exists(s) Then
    
12.             m = m + 1
    
13.             d(s) = m
    
14.             brr(m, 1) = s
    
15.             brr(m, 2) = 1
    
16.             brr(m, 3) = arr(i, 7)
    
17.             brr(m, 4) = arr(i, 8)
    
18.         Else
    
19.             r = d(s)
    
20.             brr(r, 2) = brr(r, 2) + 1
    
21.             brr(r, 3) = brr(r, 3) + arr(i, 7)
    
22.             brr(r, 4) = brr(r, 4) + arr(i, 8)
    
23.         End If
    
24.     Next
    
25.     With Sheets("工序导出")
    
26.         .[d5].Resize(5, 4) = ""
    
27.         .[d5].Resize(m, 4) = brr
    
28.     End With
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

№①June

ykcbf1100 发表于 2024-11-15 10:13
附件供参考。。。

谢谢老师的帮忙，能不能把代码写在导出的新表中，就是一点导出工序按钮，弹窗另存新表是时候直接写在新表中，

ykcbf1100

№①June 发表于 2024-11-15 10:31
谢谢老师的帮忙，能不能把代码写在导出的新表中，就是一点导出工序按钮，弹窗另存新表是时候直接写在新表 ...

算了，你那代码明显是Ai写的，我就不改了。

№①June

ykcbf1100 发表于 2024-11-15 10:50
算了，你那代码明显是Ai写的，我就不改了。

好的，谢谢老师的耐心帮忙，谢谢，小花

听歌的海

练习一下

1. Sub 汇总()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Worksheets("工序查询").[a9].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 4)
   
5.    
   
6.     For j = 2 To UBound(arr)
   
7.         s = arr(j, 6)
   
8.         If Not d.exists(s) Then
   
9.             m = m + 1
   
10.             d(s) = m
    
11.             brr(m, 1) = arr(j, 6)
    
12.             brr(m, 2) = 1
    
13.             brr(m, 3) = arr(j, 7)
    
14.             brr(m, 4) = arr(j, 8)
    
15.         Else
    
16.             r = d(s)
    
17.             brr(r, 2) = brr(r, 2) + 1
    
18.             brr(r, 3) = brr(r, 3) + arr(j, 7)
    
19.             brr(r, 4) = brr(r, 4) + arr(j, 8)
    
20.         End If
    
21.         If j >= UBound(arr) Then Exit For
    
22.     Next j
    
23.     With Worksheets("工序导出")
    
24.         .[d5].Resize(m, 4) = brr
    
25.     End With
    
26. End Sub

复制代码

№①June

听歌的海 发表于 2024-11-15 11:23
练习一下

谢谢你帮忙