自动回复欠料 （有点复杂）

makai7

大家好
请教大家一个问题，我想要编一个能够自动回复欠料的VBA程序，概况如下:

我每天都会受到一份excel表，里面都是客户下的订单，但是没料所导致的欠料报表，每天我需要大量的回复，给替代方案，全都手动，很费功夫。

附件里是欠料报表和替代方案（提单数据库可以说是我的数据库），替代方案里包挂: 编码，描述和库存

一样物料欠料可能有3至4 各物料能够替代它，但是必须要有足够的库存才能过进行替代

如:
订单1     欠item A    欠5pcs
订单2     欠item A    欠5pcs
订单2     欠item A    欠5pcs

订单1,2,3 都欠item A，总欠15 pcs
我弟代表就等于数据库，他会去查询相关物料和查看替代库存是否有足够的库存能够替代

如:
item A 的替代方案有 B 和 C，B的总库存有15 pcs（刚好）而C只有1 pcs，那么替代方案就会用B。

请大家帮忙
谢谢

yuxuan1277

个人觉得，替代数据库这样写不太容易实现。特别是当有多个替代方案时，则必须明细第一替代和第二替代，这种才有能逐个判断，然后调用库存，进行下一步操作。。。。  请高手看看有没有别的方法。。。

makai7

请问yuxuan1277
您觉得我这数据库该怎么做呢？有没有什么建议？

谢谢。

liuguansky

效果：
代码：
Sub solution()
    Dim arr, i&, str1$, str2$, dic, arrt, j&, arrre(), arrm, arrn, k&, s&, r&, arrj()
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Workbooks.Open (ThisWorkbook.Path & "\替代数据库.xls")
    With ActiveWorkbook
        With .Worksheets(1)
            arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row + 1, 4).Value
            For i = 2 To UBound(arr, 1)
                str1 = "": str2 = ""
                Do While arr(i, 1) <> ""
                    str1 = str1 & "|" & Trim(arr(i, 1))
                    str2 = str2 & "|" & Trim(arr(i, 4))
                    i = i + 1
                Loop
                dic(Mid(str1, 2)) = Mid(str2, 2)
            Next
        End With
        .Close
    End With
    With Sheet1
        arr = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(3).Row - 1, 2).Value
        arrt = dic.keys: arrs = dic.items
        For i = 1 To UBound(arr, 1)
            For j = 0 To UBound(arrt)
                If InStr(1, "|" & arrt(j) & "|", "|" & arr(i, 1) & "|") > 0 Then
                    arr(i, 1) = arrt(j)
                    If InStr(1, dic(arrt(j)), vbTab) > 0 Then
                        dic(arrt(j)) = Split(dic(arrt(j)), vbTab)(0) & vbTab & Split(dic(arrt(j)), vbTab)(1) + arr(i, 2)
                        Else: dic(arrt(j)) = dic(arrt(j)) & vbTab & arr(i, 2)
                    End If
                    Exit For
                End If
        Next j, i
        ReDim arrre(1 To UBound(arr, 1))
        For i = 1 To UBound(arr, 1)
            If dic.exists(arr(i, 1)) Then
                arrm = Split(dic(arr(i, 1)), vbTab)
                arrn = Split(arrm(0), "|")
                k = CInt(arrm(1))
                ReDim arrj(UBound(arrn))
                For j = 0 To UBound(arrn)
                    arrj(j) = CInt(arrn(j))
                Next j
                s = Application.Sum(arrj)
                r = Application.Max(arrj)
                If k <= r Then
                    For j = 0 To UBound(arrj)
                        If arrj(j) = r Then Exit For
                    Next j
                    arrre(i) = "可用" & Split(arr(i, 1), "|")(j) & "来进行替代" & k & "个"
                    ElseIf k <= s Then
                    arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & k & "个"
                    Else: arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & s & "个，但依然有" & k - s & "个不足"
                End If
                Else: arrre(i) = "No　Solution"
            End If
        Next i
        .Range("d2:d" & .Rows.Count).ClearContents
        .Cells(2, 4).Resize(i - 1, 1) = Application.Transpose(arrre)
    End With
    Application.ScreenUpdating = True
    Set dic = Nothing
End Sub
示例： 桌面.rar (20.52 KB, 下载次数: 67)

2010-12-4 00:22 上传

点击文件名下载附件

两文件放于同一文件夹下，否则请更改OPEN后的路径。

makai7

请教liuguansky
如果只能选择其中之一的替代方案呢？该怎么做？

谢谢

liuguansky

只能选择其中之一的替代方案是什么意思？

makai7

Hi liuguansky

在提供方案的时候，只能填写一个item，但是您编的程序给出的方案是 很多item能够替代某的物料，就是一样物料欠料，给的方案只给一个，而不是多个方案。

arrre(i) = "可用" & Split(arr(i, 1), "|")(j) & "来进行替代" & k & "个"
                    ElseIf k <= s Then
                    arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & k & "个"
                    Else: arrre(i) = "可用" & arr(i, 1) & "中的多个组合来替换" & s & "个，但依然有" & k - s & "个不足"

谢谢

liuguansky

只有一个可以替代？
我写的方案是如果替代的有多个，可以一起选　用，如果只能用一个物料来替代的话。还容易点。

liuguansky

Sub solution()
    Dim arr, i&, str1$, str2$, dic, arrt, j&, arrre(), arrm, arrn, k&,r&, arrj()
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Workbooks.Open (ThisWorkbook.Path & "\替代数据库.xls")
    With ActiveWorkbook
        With .Worksheets(1)
            arr = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row + 1, 4).Value
            For i = 2 To UBound(arr, 1)
                str1 = "": str2 = ""
                Do While arr(i, 1) <> ""
                    str1 = str1 & "|" & Trim(arr(i, 1))
                    str2 = str2 & "|" & Trim(arr(i, 4))
                    i = i + 1
                Loop
                dic(Mid(str1, 2)) = Mid(str2, 2)
            Next
        End With
        .Close
    End With
    With Sheet1
        arr = .Cells(2, 2).Resize(.Cells(.Rows.Count, 2).End(3).Row - 1, 2).Value
        arrt = dic.keys: arrs = dic.items
        For i = 1 To UBound(arr, 1)
            For j = 0 To UBound(arrt)
                If InStr(1, "|" & arrt(j) & "|", "|" & arr(i, 1) & "|") > 0 Then
                    arr(i, 1) = arrt(j)
                    If InStr(1, dic(arrt(j)), vbTab) > 0 Then
                        dic(arrt(j)) = Split(dic(arrt(j)), vbTab)(0) & vbTab & Split(dic(arrt(j)), vbTab)(1) + arr(i, 2)
                        Else: dic(arrt(j)) = dic(arrt(j)) & vbTab & arr(i, 2)
                    End If
                    Exit For
                End If
        Next j, i
        ReDim arrre(1 To UBound(arr, 1))
        For i = 1 To UBound(arr, 1)
            If dic.exists(arr(i, 1)) Then
                arrm = Split(dic(arr(i, 1)), vbTab)
                arrn = Split(arrm(0), "|")
                k = CInt(arrm(1))
                ReDim arrj(UBound(arrn))
                For j = 0 To UBound(arrn)
                    arrj(j) = CInt(arrn(j))
                Next j
               r = Application.Max(arrj)
                If k <= r Then
                    For j = 0 To UBound(arrj)
                        If arrj(j) = r Then Exit For
                    Next j
                    arrre(i) = "可用" & Split(arr(i, 1), "|")(j) & "来进行替代" & k & "个"
                    Else: arrre(i) = "替代个数不足"
                End If
                Else: arrre(i) = "No　Solution"
            End If
        Next i
        .Range("d2:d" & .Rows.Count).ClearContents
        .Cells(2, 4).Resize(i - 1, 1) = Application.Transpose(arrre)
    End With
    Application.ScreenUpdating = True
    Set dic = Nothing
End Sub

makai7

Hi liuguansky

不知道您会不会答应，想请您把您的逻辑写上（程序码行），有些我看不太懂。。。不知道是什么含义。。

谢谢。