怎么自动生成配送数据

绝世梦想

要求：根据系统已生成的早、中、晚食材订购表，和就餐人数表中的数据，自动生成配送数据表，其中午餐为营养餐、早/晚餐为非营养餐。配送数据表中的数量按订购表的总数量除以总人数再乘以每个学校相应的人数计算得到，价格按基础资料表中的核定单价得到，单据编号按不同时间不同学校自动生成，不能重复。肯请高手帮助写一代码，不胜感谢

lhm0926

小型MRP计算，够复杂的

zpy2

早、中、晚食材订购表，

建议存为 标准 二维表 方便计算机处理。

计算公式
每个学校的萝卜=一周三餐的萝卜*每个学校的人数

是这样的吗？

绝世梦想

zpy2 发表于 2021-1-11 14:07
早、中、晚食材订购表，

建议存为 标准 二维表 方便计算机处理。

计算公式：从周一至周日某食材的采购总量/总的就餐人数*某学校的用餐人数，就是该校该食材的的配送数量。比如：早餐订购单中周一的上肉除以就餐人数周一的早餐总人数*某学校的人数就是配送数据表中该校的配送数量，配送时间等于星期几的相应时间，单据编号根据学校的不同，时间的不同，用餐类型的不同进行进行编号，不能重复，单价取基础资料里的食材核定价格，线路为基础资料的相应学校的线路

zpy2

绝世梦想 发表于 2021-1-11 16:59
计算公式：从周一至周日某食材的采购总量/总的就餐人数*某学校的用餐人数，就是该校该食材的的配送数量。 ...

用汇总，直接用透视表，按学校和总用量，和每种食材用量都出来了，不要用 除法 拆分。

绝世梦想

zpy2 发表于 2021-1-11 17:01
用汇总，直接用透视表，按学校和总用量，和每种食材用量都出来了，不要用 除法 拆分。

要用VBA代码完成才行

zpy2

绝世梦想 发表于 2021-1-11 17:27
要用VBA代码完成才行

我猜，如果按你的思路，估计只有漫漫的等待。

绝世梦想

Sub 早餐配送()     Dim Arr, brr, crr, drr, d As Object, rr%, i%, j%, m%, n%, r%, t%, d1 As Object, d2 As Object     On Error Resume Next    t = Application.CountA(Sheets("就餐人数").[A5:A73]) - 1    Sheets("配送数据").Rows("2:50000").ClearContents     Arr = Sheets("一周菜谱").[A1].CurrentRegion     brr = Sheets("菜谱库").[A1].CurrentRegion     drr = Sheets("就餐人数").[A1].CurrentRegion     Set d = CreateObject("scripting.dictionary")     For r = 5 To t + 5     For rr = 3 To UBound(Arr, 1) Step 5         For i = 0 To 4             For j = 2 To UBound(Arr, 2)                 If Arr(rr + i, j) <> "" Then                     For m = 2 To UBound(brr)                         If Arr(rr + i, j) = brr(m, 2) Then                             crr = Split(brr(m, 3), "；")                             For n = 0 To UBound(crr)                                                             d(Split(crr(n), "，")(0)) = d(Split(crr(n), "，")(0)) + Val(Split(crr(n), "，")(1)) * drr(r, j + 3) / 500                                                           Next n                         End If                     Next m                 End If             Next j         Next i                  With Sheets("配送数据")         m = Application.CountA(.[E:E])         n = Application.CountA(.[D:D])         Sheets("配送数据").Cells(m + 1, 5).Resize(d.Count) = Application.Transpose(d.keys)         Sheets("配送数据").Cells(m + 1, 7).Resize(d.Count) = Application.Transpose(d.items)         Sheets("配送数据").Range("b" & m + 1 & ":b" & r) = Sheets("就餐人数").Range("b3")         Sheets("配送数据").Range("k" & m + 1 & ":k" & r) = "=""非营养餐"""         Sheets("配送数据").[f2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,2,0)"         Sheets("配送数据").Range("f" & m + 1 & ":f" & r).FillDown         Sheets("配送数据").[h2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,3,0)"         Sheets("配送数据").Range("h" & m + 1 & ":h" & r).FillDown         Sheets("配送数据").[j2] = "=VLOOKUP(D2,基础资料!$A$1:$I$70,9,0)"         Sheets("配送数据").Range("j" & m + 1 & ":j" & r).FillDown        For i = 2 To m        Sheets("配送数据").Cells(i, "I") = Sheets("配送数据").Cells(i, "G") * Sheets("配送数据").Cells(i, "H ")        Sheets("配送数据").Cells(i, 4).Resize(d.Count) = Sheets("就餐人数").Range("A" & i + 3)                                Next         End With          d.RemoveAll     Next rr    Next r     Set d = Nothing     Sheets("配送数据").Select End Sub

绝世梦想

Sub 早餐配送()
    Dim Arr, brr, crr, drr, d As Object, rr%, i%, j%, m%, n%, r%, t%, d1 As Object, d2 As Object
    On Error Resume Next
   t = Application.CountA(Sheets("就餐人数").[A5:A73]) - 1
   Sheets("配送数据").Rows("2:50000").ClearContents
    Arr = Sheets("一周菜谱").[A1].CurrentRegion
    brr = Sheets("菜谱库").[A1].CurrentRegion
    drr = Sheets("就餐人数").[A1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For r = 5 To t + 5
    For rr = 3 To UBound(Arr, 1) Step 5
        For i = 0 To 4
            For j = 2 To UBound(Arr, 2)
                If Arr(rr + i, j) <> "" Then
                    For m = 2 To UBound(brr)
                        If Arr(rr + i, j) = brr(m, 2) Then
                            crr = Split(brr(m, 3), "；")
                            For n = 0 To UBound(crr)
                           
                                d(Split(crr(n), "，")(0)) = d(Split(crr(n), "，")(0)) + Val(Split(crr(n), "，")(1)) * drr(r, j + 3) / 500
                             
                            Next n
                        End If
                    Next m
                End If
            Next j
        Next i
        
        With Sheets("配送数据")
        m = Application.CountA(.[E:E])
        n = Application.CountA(.[D:D])
        Sheets("配送数据").Cells(m + 1, 5).Resize(d.Count) = Application.Transpose(d.keys)
        Sheets("配送数据").Cells(m + 1, 7).Resize(d.Count) = Application.Transpose(d.items)
        Sheets("配送数据").Range("b" & m + 1 & ":b" & r) = Sheets("就餐人数").Range("b3")
        Sheets("配送数据").Range("k" & m + 1 & ":k" & r) = "=""非营养餐"""
        Sheets("配送数据").[f2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,2,0)"
        Sheets("配送数据").Range("f" & m + 1 & ":f" & r).FillDown
        Sheets("配送数据").[h2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,3,0)"
        Sheets("配送数据").Range("h" & m + 1 & ":h" & r).FillDown
        Sheets("配送数据").[j2] = "=VLOOKUP(D2,基础资料!$A$1:$I$70,9,0)"
        Sheets("配送数据").Range("j" & m + 1 & ":j" & r).FillDown
       For i = 2 To m
       Sheets("配送数据").Cells(i, "I") = Sheets("配送数据").Cells(i, "G") * Sheets("配送数据").Cells(i, "H ")
       Sheets("配送数据").Cells(i, 4).Resize(d.Count) = Sheets("就餐人数").Range("A" & i + 3)
      
      
      
       Next
        End With

        d.RemoveAll
    Next rr
   Next r
    Set d = Nothing
    Sheets("配送数据").Select
End Sub

改进上述代码后，实现大部分功能，请大神在此基码上，再改进一下代码，实现我想实现在的全部功能，谢谢

绝世梦想

zpy2 发表于 2021-1-11 17:32
我猜，如果按你的思路，估计只有漫漫的等待。

我改进了一下下面的代码，大部分功能已实现
Sub 早餐配送()
    Dim Arr, brr, crr, drr, d As Object, rr%, i%, j%, m%, n%, r%, t%, d1 As Object, d2 As Object
    On Error Resume Next
   t = Application.CountA(Sheets("就餐人数").[A5:A73]) - 1
   Sheets("配送数据").Rows("2:50000").ClearContents
    Arr = Sheets("一周菜谱").[A1].CurrentRegion
    brr = Sheets("菜谱库").[A1].CurrentRegion
    drr = Sheets("就餐人数").[A1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For r = 5 To t + 5
    For rr = 3 To UBound(Arr, 1) Step 5
        For i = 0 To 4
            For j = 2 To UBound(Arr, 2)
                If Arr(rr + i, j) <> "" Then
                    For m = 2 To UBound(brr)
                        If Arr(rr + i, j) = brr(m, 2) Then
                            crr = Split(brr(m, 3), "；")
                            For n = 0 To UBound(crr)
                           
                                d(Split(crr(n), "，")(0)) = d(Split(crr(n), "，")(0)) + Val(Split(crr(n), "，")(1)) * drr(r, j + 3) / 500
                             
                            Next n
                        End If
                    Next m
                End If
            Next j
        Next i
        
        With Sheets("配送数据")
        m = Application.CountA(.[E:E])
        n = Application.CountA(.[D:D])
        Sheets("配送数据").Cells(m + 1, 5).Resize(d.Count) = Application.Transpose(d.keys)
        Sheets("配送数据").Cells(m + 1, 7).Resize(d.Count) = Application.Transpose(d.items)
        Sheets("配送数据").Range("b" & m + 1 & ":b" & r) = Sheets("就餐人数").Range("b3")
        Sheets("配送数据").Range("k" & m + 1 & ":k" & r) = "=""非营养餐"""
        Sheets("配送数据").[f2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,2,0)"
        Sheets("配送数据").Range("f" & m + 1 & ":f" & r).FillDown
        Sheets("配送数据").[h2] = "=VLOOKUP(E2,基础资料!$L$1:$N$132,3,0)"
        Sheets("配送数据").Range("h" & m + 1 & ":h" & r).FillDown
        Sheets("配送数据").[j2] = "=VLOOKUP(D2,基础资料!$A$1:$I$70,9,0)"
        Sheets("配送数据").Range("j" & m + 1 & ":j" & r).FillDown
       For i = 2 To m
       Sheets("配送数据").Cells(i, "I") = Sheets("配送数据").Cells(i, "G") * Sheets("配送数据").Cells(i, "H ")
       Sheets("配送数据").Cells(i, 4).Resize(d.Count) = Sheets("就餐人数").Range("A" & i + 3)
      
      
      
       Next
        End With

        d.RemoveAll
    Next rr
   Next r
    Set d = Nothing
    Sheets("配送数据").Select
End Sub