如何将一个月中各周的食谱写入早晚出库登记表

定敏

ykcbf1100 发表于 2025-11-5 20:01
你这是汇总表，不是合并表，所以，顺序一般无法保持。当然，取数是按顺序取的，但是你是多个表的，无法一 ...

是这个意思，如果无法完成，那我就用您的结果再用xlookup套进原来去算了，谢谢。

ykcbf1100

定敏 发表于 2025-11-5 21:04
是这个意思，如果无法完成，那我就用您的结果再用xlookup套进原来去算了，谢谢。

应该可以的，但要明天了。

yynrzwh

仅在出库表写入重量，其它不改变

1. Sub 食材汇总()
   
2. Dim d, i&, j&, lastrow&, s, s1, k, ar
   
3. Set d = VBA.CreateObject("scripting.dictionary")
   
4. Set d("午餐") = VBA.CreateObject("scripting.dictionary")
   
5. Set d("晚餐") = VBA.CreateObject("scripting.dictionary")
   
6. For Each sh In Sheets
   
7.     If sh.Name Like "*第*周食谱*" Then
   
8.         lastrow = sh.Cells(Rows.Count, 1).End(3).Row - 1
   
9.         lastcol = sh.Cells(5, Columns.Count).End(xlToLeft).Column
   
10.         ar = sh.Range("a4", sh.Cells(lastrow, lastcol))
    
11.         For i = 3 To UBound(ar) - 1
    
12.             If ar(i, 1) <> "" Then s = ar(i, 1)
    
13.             For j = 2 To UBound(ar, 2) Step 4
    
14.                 If ar(i, j + 1) <> "" Then
    
15.                     s1 = ar(i, j + 1) & CDate(ar(1, j))
    
16.                     d(s)(s1) = d(s)(s1) + ar(i, j + 3)
    
17.                 End If
    
18.             Next
    
19.         Next
    
20.     End If
    
21. Next
    
22. 
    
23. For Each k In d.keys
    
24.     With Sheets(k & "出库登记表")
    
25.         lastrow = .Cells(8, "C").End(xlDown).Row
    
26.         lastcol = .Cells(2, Columns.Count).End(xlToLeft).Column
    
27.         For i = 8 To lastrow
    
28.             For j = 1 To lastcol
    
29.                 rq = .Cells(2, j).Value
    
30.                 If VBA.IsDate(rq) Then
    
31.                     s = .Cells(i, 3) & CDate(rq)
    
32.                     If d(k).exists(s) Then
    
33.                         .Cells(i, j) = d(k)(s)
    
34.                     End If
    
35.                 End If
    
36.             Next
    
37.         Next
    
38.     End With
    
39. Next
    
40. 
    
41. Set d = Nothing
    
42. End Sub
    

复制代码