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

hbszls

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

你好，麻烦有时间时帮忙写下标黄色的列，谢谢！

quqiyuan

hbszls 发表于 2025-4-18 08:49
你好，麻烦有时间时帮忙写下标黄色的列，谢谢！

你这个有点矛盾吧
1、毛利率(2)%=(建议单价-总成本(1))/建议单价，毛利率要建议单价
2、建议单价，(5)=(3)/(4)
这两个一定需要有个确定才行吧

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("食谱库")
    sht.[a1].CurrentRegion.Offset(4).Clear
    s = Split(sht.[j2], "至")
    arr = sh.[a1].CurrentRegion
    brr = sh1.[a1].CurrentRegion
    crr = sht.[a1].Resize(1000, 12)
    Set d = CreateObject("scripting.dictionary")
    For i = 3 To UBound(brr)
        ss = brr(i, 2)
        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 = 3 To 14 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), 16)
                    crr(n, 9) = brr(d(s), 17)
                    crr(n, 11) = drr(i, 3)
                End If
            Next
        End If
    Next
    With sht
        .[a1].Resize(1000, 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)
                .Cells(i, 10) = IIf(.Cells(i, 10) = Empty, .Cells(i, 8) / (1 - .Cells(i, 9)) * .Cells(i, 11), .Cells(i, 10))
                .Cells(i, 12) = IIf(.Cells(i, 12) = Empty, .Cells(i, 8) / (1 - .Cells(i, 9)), .Cells(i, 12))
            End If
        Next
        .[a5].Resize(n - 4, 12).Borders.LineStyle = 1
        .[a1].CurrentRegion.HorizontalAlignment = xlCenter
        With .Range("a5").Resize(n - 4, 12)
            .WrapText = True
            With .Font
                .Name = "宋体"
                .Size = 10
            End With
        End With
        .Rows("5" & ":" & n).RowHeight = 18
        .Columns("i").NumberFormat = "0%"
        .Columns("j").NumberFormat = "0.0"
        .Columns("l").NumberFormat = "0.0"
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
    Set d = Nothing
End Sub

hbszls

quqiyuan 发表于 2025-4-18 17:53
参与一下，仅供参考，。。。

谢谢！满足了要求。