求大佬们帮帮忙，数据提取的问题。

hbszls

1、按J2单位格指定的日期区间生成核算表，日期重复时覆盖，不重复时累加。
2、根据周食谱的安排获取菜名。
3、再根据菜名从食谱库中获取主料及辅料相关信息。

感谢quqiyuan、翁知江安等网友的帮助，刚刚更新了附件，恳请有时间的大佬帮忙完善下。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet, sh1 As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("核算表")
    Set sh = wb.Sheets("周食谱")
    Set sh1 = wb.Sheets("食谱库")
    s = Split(sht.[j2], "至")
    arr = sh.[a1].CurrentRegion
    brr = sh1.[a1].CurrentRegion
    crr = sht.[a1].Resize(10000, 12)
    Set d = CreateObject("scripting.dictionary")
    For i = 3 To UBound(brr)
        ss = brr(i, 3)
        If Not d.exists(ss) Then
            d(ss) = i
        End If
    Next
    ReDim drr(1, 1 To 1)
    For i = 2 To UBound(arr)
        If arr(i, 1) >= CDate(s(0)) And arr(i, 1) <= CDate(s(1)) Then
            n = n + 1
            ReDim Preserve drr(1, 1 To n)
            drr(0, n) = arr(i, 1)
            drr(1, n) = arr(i, 4)
        End If
    Next
    drr = Application.Transpose(drr)
    n = 4
    For i = 1 To UBound(drr)
        s = drr(i, 2)
        If d.exists(s) Then
            For j = 4 To 15 Step 3
                If brr(d(s), j) <> Empty Then
                    n = n + 1
                    crr(n, 1) = drr(i, 1)
                    crr(n, 2) = drr(i, 2)
                    crr(n, 3) = brr(d(s), j)
                    crr(n, 4) = brr(d(s), j + 2)
                    crr(n, 7) = brr(d(s), 17)
                End If
            Next
        End If
    Next
    With sht
        .[a1].Resize(10000, 12) = crr
        r = .Cells(Rows.Count, 1).End(3).Row
        For i = r To 6 Step -1
            If crr(i, 1) = crr(i - 1, 1) And crr(i, 2) = crr(i - 1, 2) Then
                .Cells(i - 1, 1).Resize(2).Merge
                .Cells(i - 1, 2).Resize(2).Merge
                .Cells(i - 1, 7).Resize(2).Merge
            End If
        Next
        .[a5].Resize(n - 4, 12).Borders.LineStyle = 1
        .[a1].CurrentRegion.HorizontalAlignment = xlCenter
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
    Set d = Nothing
End Sub

hbszls

quqiyuan 发表于 2025-4-12 21:10
代码如下。。。
Sub test()
    Application.ScreenUpdating = False

非常感谢！刚才更新了下附件，麻烦有时间帮帮忙再改下，谢谢！

翁知江安

Sub test250413a()
Dim i, j, k, m, n As Integer, ar, br, cr, dr As Variant, startdate, enddate
Application.DisplayAlerts = False
startdate = CDate(Split(Sheets("&#186;&#203;&#203;&#227;±í").[j2], "&#214;&#193;")(0))
enddate = CDate(Split(Sheets("&#186;&#203;&#203;&#227;±í").[j2], "&#214;&#193;")(1))
ar = Sheets("&#214;&#220;&#202;&#179;&#198;×").[a1].CurrentRegion
ReDim br(1 To UBound(ar) - 1, 1 To 2)
For i = 2 To UBound(ar)
If ar(i, 1) >= startdate And ar(i, 1) <= enddate Then
    m = m + 1
    br(m, 1) = ar(i, 1): br(m, 2) = ar(i, 4)
  End If
Next
cr = Sheets("&#202;&#179;&#198;×&#191;&#226;").UsedRange
ReDim dr(1 To 1000, 1 To 7)
For k = 1 To m
  For i = 3 To UBound(cr)
    If br(k, 2) = cr(i, 3) Then
       For j = 4 To 13 Step 3
         If cr(i, j) <> "" Then
            n = n + 1
            dr(n, 1) = br(k, 1): dr(n, 2) = br(k, 2)
            dr(n, 3) = cr(i, j): dr(n, 4) = cr(i, j + 2)
            dr(n, 7) = cr(i, 17)
         End If
       Next
       Exit For
    End If
  Next
Next
With Sheets("&#186;&#203;&#203;&#227;±í")
.[a5].Resize(300, 7).Clear
.[a5].Resize(n, 7) = dr
.[a5].Resize(n, 7).Borders.LineStyle = 1
For k = n + 3 To 5 Step -1
    If dr(k - 4, 1) = dr(k - 3, 1) And dr(k - 4, 2) = dr(k - 3, 2) Then
   .Cells(k, 1).Resize(2, 1).Merge
   .Cells(k, 2).Resize(2, 1).Merge
   .Cells(k, 7).Resize(2, 1).Merge
   End If
Next
End With
Application.DisplayAlerts = True
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

hbszls

翁知江安 发表于 2025-4-13 18:32
供参考，欢迎批评指正

谢谢！忘记了说明，附件我更新了。

quqiyuan

hbszls 发表于 2025-4-14 15:06
谢谢！忘记了说明，附件我更新了。

参与一下，仅供参考。。。

你模拟数据计算错误，60*0.3=18，不是1.8，请留意

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet, sh1 As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("核算表")
    Set sh = wb.Sheets("周食谱")
    Set sh1 = wb.Sheets("食谱库")
    sht.[a1].CurrentRegion.Offset(4).Clear
    s = Split(sht.[j2], "至")
    arr = sh.[a1].CurrentRegion
    brr = sh1.[a1].CurrentRegion
    crr = sht.[a1].Resize(10000, 12)
    Set d = CreateObject("scripting.dictionary")
    For i = 3 To UBound(brr)
        ss = brr(i, 3)
        If Not d.exists(ss) Then
            d(ss) = i
        End If
    Next
    ReDim drr(2, 1 To 1)
    For i = 2 To UBound(arr)
        If arr(i, 1) >= CDate(s(0)) And arr(i, 1) <= CDate(s(1)) Then
            n = n + 1
            ReDim Preserve drr(2, 1 To n)
            drr(0, n) = arr(i, 1)
            drr(1, n) = arr(i, 4)
            drr(2, n) = arr(i, 5)
        End If
    Next
    drr = Application.Transpose(drr)
    n = 4
    For i = 1 To UBound(drr)
        s = drr(i, 2)
        If d.exists(s) Then
            For j = 4 To 15 Step 3
                If brr(d(s), j) <> Empty Then
                    n = n + 1
                    crr(n, 1) = drr(i, 1)
                    crr(n, 2) = drr(i, 2)
                    crr(n, 3) = brr(d(s), j)
                    crr(n, 4) = brr(d(s), j + 1)
                    crr(n, 5) = brr(d(s), j + 2)
                    crr(n, 6) = crr(n, 4) * crr(n, 5)
                    crr(n, 7) = brr(d(s), 17)
                    crr(n, 11) = drr(i, 3)
                    crr(n, 12) = brr(d(s), 18)
                End If
            Next
        End If
    Next
    With sht
        .[a1].Resize(10000, 12) = crr
        r = .Cells(Rows.Count, 1).End(3).Row
        For i = r To 5 Step -1
            If crr(i, 1) = crr(i - 1, 1) And crr(i, 2) = crr(i - 1, 2) Then
                .Cells(i - 1, 1).Resize(2).Merge
                .Cells(i - 1, 2).Resize(2).Merge
                .Cells(i - 1, 7).Resize(2).Merge
                .Cells(i, 8) = IIf(.Cells(i, 8) = Empty, .Cells(i, 6), .Cells(i, 8)) + .Cells(i, 7)
                .Cells(i - 1, 8) = .Cells(i, 8) + .Cells(i - 1, 6)
                .Cells(i - 1, 8).Resize(2).Merge
                .Cells(i - 1, 9).Resize(2).Merge
                .Cells(i - 1, 10).Resize(2).Merge
                .Cells(i - 1, 11).Resize(2).Merge
                .Cells(i - 1, 12).Resize(2).Merge
            Else
                .Cells(i, 8) = IIf(.Cells(i, 8) = Empty, .Cells(i, 6), .Cells(i, 8)) + .Cells(i, 7)
            End If
        Next
        .[a5].Resize(n - 4, 12).Borders.LineStyle = 1
        .[a1].CurrentRegion.HorizontalAlignment = xlCenter
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
    Set d = Nothing
End Sub
   
   
   
   

hbszls

quqiyuan 发表于 2025-4-16 12:30
代码如下。。。
Sub test()
    Application.ScreenUpdating = False

你好，麻烦有时间帮忙把标黄色底色的三列补充下，谢谢！