VBA快速匹配计算出采购单位的数量

SCWYZJ

求助：因为供货商是以大单位供货的，所以必须把小单位换算成大单位，才能下采购单，（见附件），麻烦老师帮忙看看，可不可以写自定义函数或者用工作表事件的形式，让其自动计算匹配大单位方便采购下货。谢谢，小花静候！

zxsea_7426

供参考:(此采购数量到货后,库存量允许超过最高库存量1 个采购单位,即取整上浮1个整数单位)

'https://club.excelhome.net/thread-1697719-1-1.html
Sub 快速求采购数量()
    la_ro = Cells(Rows.Count, "B").End(3).Row
    ar = Cells(3, 2).Resize(la_ro - 2, 6)
    Set reg = CreateObject("VBScript.RegExp")
    Set d = CreateObject("scripting.dictionary")
    With reg
        .Global = True
        .Pattern = "(\d+)([\u4e00-\u9fa5])\/([\u4e00-\u9fa5])"      '[\u4e00-\u9fa5]
        For i = 1 To UBound(ar)
            If ar(i, 2) = ar(i, 5) Then     '库存单位与采购单位一致不需进行匹配
                ar(i, 6) = ar(i, 4) - ar(i, 3)
            Else
                     '******************************************
                    '库存单位与采购单位不一致需要匹配计算
                    '清楚字典内容，并记录新信息与数据
                    d.RemoveAll
                    If .test(ar(i, 1)) Then
                        Set ma = .Execute(ar(i, 1))
                        For Each m In ma
                            数量 = Val(m.submatches(0))
                            小单位 = m.submatches(1)
                            大单位 = m.submatches(2)
                            d(小单位) = Array(大单位, 数量)
                        Next
                    End If
                    
                    '根据字典记录的数据进行匹配
                    If d.Count >= 1 Then
                        If d.exists(ar(i, 2)) Then
                            New_小单位 = ar(i, 2)
                            采购数量 = 0
                            需求量 = ar(i, 4) - ar(i, 3)
                            If 需求量 > 0 Then
                                Do
                                    采购数量 = WorksheetFunction.RoundUp(需求量 / d(New_小单位)(1), 0)
                                    需求量 = 采购数量
                                    New_小单位 = d(New_小单位)(0)
                                Loop Until Not d.exists(New_小单位)      '没有更高一级的单位结束循环
                            End If
                            ar(i, 6) = 采购数量
                        End If
                    End If
                    '******************************************
            End If
        Next i
    End With
    Cells(3, 7).Resize(UBound(ar), 1) = Application.WorksheetFunction.Index(ar, 0, 6)
End Sub

zxsea_7426

quqiyuan

参与一下，供参考。。。

SCWYZJ

谢谢楼上的几位老师，我下去好好研究一下，能自定义函数就更好了

quqiyuan

SCWYZJ 发表于 2024-7-21 20:16
谢谢楼上的几位老师，我下去好好研究一下，能自定义函数就更好了

自定义函数也可以啊，在前面的过程修改一下即可，改了下，供你参考。。。

yjh_27

SCWYZJ 发表于 2024-7-21 20:16
谢谢楼上的几位老师，我下去好好研究一下，能自定义函数就更好了

参考4L代码改为自定义函数，并修正一个bug

SCWYZJ

quqiyuan 发表于 2024-7-21 20:46
自定义函数也可以啊，在前面的过程修改一下即可，改了下，供你参考。。。

函数是可以，但不是动态的的，区域变了就不行了

quqiyuan

SCWYZJ 发表于 2024-7-21 21:53
函数是可以，但不是动态的的，区域变了就不行了

你列数顺序和列数不能变，这个已经固定死了。。。

SCWYZJ

quqiyuan 发表于 2024-7-21 21:58
你列数顺序和列数不能变，这个已经固定死了。。。

好的，谢谢。我去试试