如何生成营养成份分析表

绝世梦想

求助：根据带量食谱，在营养成份分析表中，选择食谱名称时，自动带出食谱的商品明细及数量，并在下面的营养成份分析表中算出每种营养成份每周当天的数值

3190496160

胆固醇，根据什么来计算，食谱中并没有这一项的嘛

绝世梦想

3190496160 发表于 2024-4-30 07:18
胆固醇，根据什么来计算，食谱中并没有这一项的嘛

第一张表应该是手工填制的
第二张表的上半部分的营养食谱是通过选择食谱名称带出商品和数量列
第二张表下面的部分是根据营养食谱选择的内容计算出各种营养成份所以  按第一张的设置就好了  不管有不有胆固醇，第一张表有什么就计算什么就好了

3190496160

Private Sub Worksheet_Change(ByVal T As Range)
If T.Row > 3 And T.Column > 4 And T.Row < 31 Then
    If T.Count > 1 Then End
    If T.Value = "" Then End
    y = Cells(3, Columns.Count).End(xlToLeft).Column
    If T.Column > y Then End
    Dim ar As Variant
    Dim i As Long, rs As Long
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    r = T.Row
    x = T.Column
    If Cells(2, x) = "" Then End
    With Sheets("带量食谱")
        rs = .Cells(Rows.Count, 3).End(xlUp).Row
        If rs < 3 Then MsgBox "带量食谱为空，请先导入数据！": End
        ar = .Range("a2:r" & rs)
    End With
    ws = Cells(Rows.Count, 1).End(xlUp).Row
    Dim br()
    ReDim br(1 To UBound(ar), 1 To 2)
    zd = T.Value
    For i = 2 To UBound(ar)
        If ar(i, 2) = Empty Then ar(i, 2) = ar(i - 1, 2)
        If ar(i, 2) = zd Then
            n = n + 1
            For j = 3 To 4
                br(n, j - 2) = ar(i, j)
            Next j
        End If
    Next i
    Cells(r, x + 1).Resize(n, 2) = br
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row > 3 And T.Column > 4 Then
    If T.Count > 1 Then End
    y = Cells(3, Columns.Count).End(xlToLeft).Column
    If T.Column > y Then End
    Dim ar As Variant
    Dim i As Long, rs As Long
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    r = T.Row
    x = T.Column
    If Cells(2, x) = "" Then End
    With Sheets("带量食谱")
        rs = .Cells(Rows.Count, 3).End(xlUp).Row
        If rs < 3 Then MsgBox "带量食谱为空，请先导入数据！": End
        ar = .Range("a2:r" & rs)
    End With
    For i = 2 To UBound(ar)
        If ar(i, 2) <> Empty Then
            d(ar(i, 2)) = ""
        End If
    Next i
    With T.Validation
        .Delete
        .Add 3, 1, 1, Join(d.keys, ",")
    End With
End If
End Sub

3190496160

Sub 统计()
Dim ar As Variant
Dim i As Long, rs As Long
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim rn As Range
Dim cr()
With Sheets("带量食谱")
    rs = .Cells(Rows.Count, 3).End(xlUp).Row
    If rs < 3 Then MsgBox "带量食谱为空，请先导入数据！": End
    ar = .Range("a2:r" & rs)
End With
For i = 2 To UBound(ar)
    If ar(i, 2) <> "" Then
        zf = ar(i, 2)
        d(zf) = i
    End If
Next i
With Sheets("营养成分分析")
    Set rn = .Columns(1).Find("营养成分", , , , , , 1)
    If rn Is Nothing Then MsgBox "营养成分分析Al列没有【营养成分】字段！": End
    ks = rn.Row
    br = .Range("a1:s" & ks - 2)
    ws = .Cells(Rows.Count, 1).End(xlUp).Row
    If ws >= 33 Then .Range("a33:s" & ws) = Empty
    ReDim cr(1 To UBound(br, 2), 1 To 19)
    For j = 5 To 17 Step 3
        For i = 4 To UBound(br)
            If br(i, j) <> "" Then
                xh = d(br(i, j))
                If xh <> "" Then
                    For s = 5 To UBound(ar, 2)
                        T = dc(ar(1, s))
                        If T = "" Then
                            k = k + 1
                            dc(ar(1, s)) = k
                            T = k
                            rr = Split(ar(1, s), "(")
                            cr(k, 1) = rr(0)
                            cr(k, 2) = Replace(rr(1), ")", "")
                        End If
                        cr(T, j) = cr(T, j) + Val(ar(xh, s))
                    Next s
                End If
            End If
        Next i
    Next j
    .Cells(ks + 1, 1).Resize(k, UBound(cr, 2)) = cr
End With
MsgBox "ok!"
End Sub

3190496160

营养成份分析工具111.rar (49.08 KB, 下载次数: 4)

2024-5-1 09:46 上传

点击文件名下载附件

3190496160

1、统计结果未核对，也没法核对，自己核对看看
2、营养成分统计用按钮完成
如果还有问题，可以加v

绝世梦想

3190496160 发表于 2024-5-1 09:47
1、统计结果未核对，也没法核对，自己核对看看
2、营养成分统计用按钮完成
如果还有问题，可以加v

好的   非常感谢

绝世梦想

3190496160 发表于 2024-5-1 09:47
1、统计结果未核对，也没法核对，自己核对看看
2、营养成分统计用按钮完成
如果还有问题，可以加v

我先试试 如有问题再请教

绝世梦想

3190496160 发表于 2024-5-1 09:47
1、统计结果未核对，也没法核对，自己核对看看
2、营养成分统计用按钮完成
如果还有问题，可以加v

非常完美，计算出来的数据没有问题。只是有个小BUG,执行按钮分析时，营养成份分析的标题行不见了