多条件提取数据

ykcbf1100

每周食谱表D2单元格的日期区间更正。

1. Sub ykcbf()   '//2024.7.8  每周食谱(三个条件:每周、星期、餐别)
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim tm: tm = Timer
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     On Error Resume Next
   
8.     Set ws = ThisWorkbook
   
9.     For Each sht In ws.Sheets
   
10.         If InStr(sht.Name, "周") Then sht.Delete
    
11.     Next
    
12.     p = ws.Path & ""
    
13.     Set Sh = ws.Sheets("需求样式")
    
14.     bt = 1: col = 2
    
15.     With Sheets("每日食谱模拟数据")
    
16.         r = .Cells(Rows.Count, col).End(3).Row
    
17.         c = .UsedRange.Columns.Count
    
18.         arr = .[a1].Resize(r, c)
    
19.     End With
    
20.     For i = bt + 1 To UBound(arr)
    
21.         s = arr(i, col)                        '//每周一表
    
22.         ss = "星期" & Weekday(arr(i, 1)) - 1   '//星期提取
    
23.         sss = arr(i, 3)                        '//餐别
    
24.         If Not d1.exists(s) Then
    
25.             d1(s) = Array(arr(i, 1), arr(i, 1))
    
26.         Else
    
27.             t = d1(s)
    
28.             t(1) = arr(i, 1)
    
29.             d1(s) = t
    
30.         End If
    
31.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
32.         If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
    
33.         d(s)(ss)(sss) = d(s)(ss)(sss) & Chr(10) & arr(i, 4)
    
34.     Next
    
35.     For Each k In d.keys
    
36.         Sh.Copy After:=ws.Sheets(ws.Sheets.Count)
    
37.         Set sht = ws.Sheets(ws.Sheets.Count)
    
38.         m = 0
    
39.         ReDim brr(1 To 5, 1 To 4)
    
40.         rq1 = d1(k)(0): rq2 = d1(k)(1)
    
41.         With sht
    
42.             For Each kk In d(k).keys
    
43.                 m = m + 1
    
44.                 .Name = k
    
45.                 .[a1] = k & "菜谱"
    
46.                 .[a4:d8] = ""
    
47.                 .[d2] = rq1 & "至" & rq2
    
48.                 brr(m, 1) = kk
    
49.                 n = 1
    
50.                 For Each kkk In d(k)(kk).keys
    
51.                     n = n + 1
    
52.                     brr(m, n) = Mid(d(k)(kk)(kkk), 2)
    
53.                 Next
    
54.             Next
    
55.             .[a4].Resize(m, 4) = brr
    
56.         End With
    
57.     Next
    
58.     Set d = Nothing
    
59.     Application.ScreenUpdating = True
    
60.     Application.DisplayAlerts = True
    
61.     MsgBox "拆分完毕，共用时：" & Format(Timer - tm) & "秒！"
    
62. End Sub
    
63. 
    

复制代码

h2016

每日学生食谱不错不错

hbszls

grf1973 发表于 2024-7-8 15:04
参与一下。。。。。。。。。

你好，感谢你的帮助，效果很满意。能否有时间时帮改为样式二的格式。

grf1973

自己先把食谱库更新好再说。做到每日食谱上的菜品在库里都有。