食材采购分类登记汇总

SCWYZJ

求助:厨房每天要采购很多食材，每月汇总的时候很头痛，要分类分量分金额汇总，（见附件），来此求助大神老师帮慢看看，如何用VBA实现，谢谢，小花静候。

chxw68

详见附件。

笨鸟飞不高

ykcbf1100

交个作业吧，代码总感觉可读性不太好。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.25
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set d3 = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     With Sheets("分类")
   
7.         r = .Cells(Rows.Count, 2).End(3).Row
   
8.         arr = .[a1].Resize(r, 22)
   
9.     End With
   
10.     For j = 3 To UBound(arr, 2)
    
11.         For i = 5 To UBound(arr)
    
12.             s = arr(i, j)
    
13.             If s <> Empty Then d1(s) = arr(4, j)  '//确定类别与素材的关系
    
14.         Next
    
15.     Next
    
16.     For j = 3 To UBound(arr, 2)
    
17.         s = arr(4, j)         '//固定类别列号
    
18.         d3(s) = j
    
19.     Next
    
20.     With Sheets("录入")
    
21.         r = .Cells(Rows.Count, 2).End(3).Row
    
22.         arr = .[a1].Resize(r, 5).Value
    
23.         Sum = .[e3].Value   '//总金额
    
24.     End With
    
25.     rq = CDate(Split(arr(3, 3))(0))
    
26.     For i = 5 To UBound(arr)
    
27.         st = arr(i, 3)
    
28.         If Val(arr(i, 2)) Then
    
29.             If d1.exists(st) Then s = d1(st) & "|" & rq
    
30.             je = Val(arr(i, 4)) * Val(arr(i, 5))
    
31.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
32.             If Not d(s).exists(st) Then
    
33.                 d(s)(st) = Array(arr(i, 4), je, arr(i, 3))
    
34.             Else
    
35.                 t = d(s)(st)
    
36.                 t(0) = t(0) + arr(i, 4)
    
37.                 t(1) = t(1) + je
    
38.                 d(s)(st) = t
    
39.             End If
    
40.         End If
    
41.     Next
    
42.     ReDim brr(1 To 1, 1 To 100)
    
43.     For Each k In d.keys
    
44.         b = Split(k, "|")
    
45.         j = d3(b(0))
    
46.         brr(1, 1) = b(1)
    
47.         brr(1, 2) = Sum
    
48.         For Each kk In d(k).keys
    
49.             brr(1, j) = kk & "(" & d(k)(kk)(0) & "-" & d(k)(kk)(1) & ")"
    
50.         Next
    
51.     Next
    
52.     With Sheets("汇总")
    
53.         r = .Cells(Rows.Count, 3).End(3).Row
    
54.         .Cells(r + 1, 3).Resize(1, 22) = brr
    
55.     End With
    
56.     Set d = Nothing
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "OK！"
    
59. End Sub
    

复制代码

笨鸟飞不高

grf1973

。。。。。。。。。。。。。。

SCWYZJ

谢谢各位老师的帮助，我试了下，7楼老师的最完美，2楼老师的也非常好，5楼老师的代码没有把所有的食材导出。6楼老师的代码也不错，只是图片不方便复制提取。再次感谢大神们顶力帮助。谢谢

usedrange

1. Sub t()
   
2.     Dim m%, arr, brr, crr, num%, p%, dic, d, i%, j, je%, s, r%
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     ReDim crr(1 To 10, 1 To 23)
   
7.     With Sheets("分类")
   
8.         brr = .Range("b4:v" & .[b4].End(4).Row)
   
9.         For i = 2 To UBound(brr)
   
10.             For j = 2 To UBound(brr, 2)
    
11.                 If brr(i, j) <> "" Then
    
12.                     d(j & "|" & brr(1, j)) = d(j & "|" & brr(1, j)) & brr(i, j) & "|"
    
13.                 End If
    
14.             Next j
    
15.         Next i
    
16.     End With
    
17.     With Sheets("录入")
    
18.         r = 1
    
19.         m = .[c5].End(4).Row
    
20.         arr = .Range("c5:e" & m)
    
21.         For i = 1 To UBound(arr)
    
22.             dic(arr(i, 1) & "|" & arr(i, 3)) = dic(arr(i, 1) & "|" & arr(i, 3)) + arr(i, 2)
    
23.         Next i
    
24.         For Each k In dic.keys
    
25.             crr(r, 1) = r
    
26.             crr(r, 2) = .[c3]
    
27.             crr(r, 3) = .[e3]
    
28.             s = Split(k, "|")
    
29.             For Each j In d.keys
    
30.                 If InStr(d(j), s(0)) > 0 Then
    
31.                     d2(j) = d2(j) + 1
    
32.                     r = d2(j)
    
33.                     crr(r, Int(Split(j, "|")(0)) + 2) = s(0) & "(" & dic(k) & "-" & dic(k) * s(1) & ")"
    
34.                     Exit For
    
35.                 End If
    
36.             Next j
    
37.         Next k
    
38.         Sheets("汇总").[b8].Resize(UBound(crr), UBound(crr, 2)) = crr
    
39.     End With
    
40.     Set dic = Nothing
    
41.     Set d = Nothing
    
42.     Set d2 = Nothing
    
43. End Sub
    

复制代码

yynrzwh

中文版

1. Sub 汇总()
   
2. Dim 分类表, 单价表, 采购表, 汇总表
   
3. Dim 分类字典 As Object, 单价字典 As Object, 采购字典 As Object, 列号字典 As Object
   
4. Dim i&, j&
   
5. 
   
6. Set 分类字典 = VBA.CreateObject("scripting.dictionary")
   
7. Set 单价字典 = VBA.CreateObject("scripting.dictionary")
   
8. 
   
9. With Sheets("分类")
   
10.     分类表 = .Range("b4").CurrentRegion
    
11.     单价表 = .Range("x4").CurrentRegion
    
12. End With
    
13. 
    
14. For i = 2 To UBound(分类表)
    
15.     For j = 1 To UBound(分类表, 2)
    
16.         If 分类表(i, j) <> "" Then
    
17.             分类字典(分类表(i, j)) = 分类表(1, j)
    
18.         End If
    
19.     Next
    
20. Next
    
21. 
    
22. For i = 2 To UBound(单价表)
    
23.     单价字典(单价表(i, 2)) = 单价表(i, 3)
    
24. Next
    
25. 
    
26. Dim 最后行&, 行号&
    
27. With Sheets("汇总")
    
28.     最后行 = .Cells(Rows.Count, 3).End(3).Row + 1
    
29.     汇总表 = .Range("a1").Resize(最后行 + 1000, 24)
    
30. End With
    
31. 
    
32. Set 列号字典 = VBA.CreateObject("scripting.dictionary")
    
33. For j = 2 To UBound(汇总表, 2)
    
34.     列号字典(汇总表(4, j)) = j
    
35. Next
    
36. 
    
37. 采购表 = Sheets("录入").Range("b3").CurrentRegion
    
38. Set 采购字典 = VBA.CreateObject("scripting.dictionary")
    
39. For i = 4 To UBound(采购表)
    
40.     If 采购表(i, 2) <> Empty Then
    
41.         采购字典(采购表(i, 2)) = 采购字典(采购表(i, 2)) + 采购表(i, 3)
    
42.     End If
    
43. Next
    
44. 
    
45. 行号 = 最后行
    
46. Do
    
47.     汇总表(行号, 2) = 汇总表(行号 - 1, 2) + 1
    
48.     汇总表(行号, 3) = 采购表(2, 2)
    
49.     For Each k In 采购字典.keys
    
50.         列号 = 列号字典(分类字典(k))
    
51.         If 汇总表(行号, 列号) = "" Then
    
52.             汇总表(行号, 4) = 汇总表(行号, 4) + 采购字典(k) * 单价字典(k)
    
53.             汇总表(行号, 列号) = k & "(" & 采购字典(k) & "-" & 采购字典(k) * 单价字典(k) & ")"
    
54.             采购字典.Remove k
    
55.         End If
    
56.     Next
    
57.     行号 = 行号 + 1
    
58. Loop While 采购字典.Count > 0
    
59. 
    
60. Sheets("汇总").Range("a1").Resize(行号, 24) = 汇总表
    
61. 
    
62. Set 分类字典 = Nothing
    
63. Set 单价字典 = Nothing
    
64. Set 采购字典 = Nothing
    
65. Set 列号字典 = Nothing
    
66. 
    
67. End Sub
    

复制代码