将配方表数据透视后去除里面的水分，重新计算各原料占比

山海风云轩

求助：比如现在有一个配方表，里面有单体原料以及复配原料，有水存在，

现在需要对其数据透视后，得到单体形式的“实际成分含量表”，
然后在此基础上，去掉其中的水分，重新计算各原料的占比，形成新的“实际成分含量表”
具体详情见附件

hlxue

直接将原数据中的“水”删除，再作透视表就行了。

山海风云轩

hlxue 发表于 2024-2-26 17:33
直接将原数据中的“水”删除，再作透视表就行了。

数据源中可能存在复配原料，合并单元格等等

shiruiqiang

算出来怎么不同？

山海风云轩

shiruiqiang 发表于 2024-2-26 18:11
算出来怎么不同？

因为少了一个原料，“氢化淀粉水解物”漏掉了

山海风云轩

shiruiqiang 发表于 2024-2-26 18:11
算出来怎么不同？

另外，展示的时候可以降序排列吗？

山海风云轩

有路过的大佬帮忙看看吗？

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With ThisWorkbook.Worksheets("水嫩冻干粉")
   
7.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.         arr = .Range("a3:m" & r)
   
9.     End With
   
10.     s = 0
    
11.     For i = 1 To UBound(arr)
    
12.         If arr(i, 2) <> "水" Then
    
13.             If Not d.exists(arr(i, 2)) Then
    
14.                 ReDim brr(1 To 4)
    
15.                 brr(1) = m
    
16.                 brr(2) = arr(i, 2)
    
17.                 brr(3) = arr(i, 3)
    
18.             Else
    
19.                 brr = d(arr(i, 2))
    
20.             End If
    
21.             brr(4) = brr(4) + arr(i, 6)
    
22.             s = s + arr(i, 6)
    
23.             d(arr(i, 2)) = brr
    
24.         End If
    
25.     Next
    
26.     ReDim crr(1 To d.Count, 1 To 4)
    
27.     m = 0
    
28.     For Each aa In d.keys
    
29.         m = m + 1
    
30.         brr = d(aa)
    
31.         brr(4) = brr(4) / s * 100
    
32.         For j = 1 To UBound(brr)
    
33.             crr(m, j) = brr(j)
    
34.         Next
    
35.     Next
    
36.     With ThisWorkbook.Worksheets("sheet1")
    
37.         .Cells.Clear
    
38.         .Columns(4).NumberFormatLocal = "0.000000000000000000000"
    
39.         With .Range("a1")
    
40.             .Value = "产品实际成分含量表"
    
41.             .Resize(1, 4).Merge
    
42.             With .Font
    
43.                 .Name = "微软雅黑"
    
44.                 .Size = 16
    
45.             End With
    
46.         End With
    
47.         With .Range("a2:d2")
    
48.             .Value = Array("序号", "标准中文名称", "INCI名", "实际成分含量（%）")
    
49.             .Borders.LineStyle = xlContinuous
    
50.             With .Font
    
51.                 .Name = "微软雅黑"
    
52.                 .Size = 12
    
53.                 .Bold = True
    
54.             End With
    
55.         End With
    
56.         With .Range("a3").Resize(UBound(crr), UBound(crr, 2))
    
57.             .Value = crr
    
58.             .Borders.LineStyle = xlContinuous
    
59.             With .Font
    
60.                 .Name = "微软雅黑"
    
61.                 .Size = 12
    
62.             End With
    
63.         End With
    
64.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)).Sort key1:=.Range("d2"), order1:=xlDescending, Header:=xlNo
    
65.         For i = 1 To UBound(crr)
    
66.             crr(i, 1) = i
    
67.         Next
    
68.         .Range("a3").Resize(UBound(crr), 1) = crr
    
69.         With .UsedRange
    
70.             .HorizontalAlignment = xlCenter
    
71.             .VerticalAlignment = xlCenter
    
72.         End With
    
73.     End With
    
74. End Sub
    

复制代码

chxw68

详见附件。

山海风云轩

chxw68 发表于 2024-2-28 15:46
详见附件。

感谢大佬