订单的组合商品拆分成单个商品

Tim_miT

各位大神，求助一下
现在销售订单里有组合的商品，希望可以根据基础数据“data”中的一对多关系进行拆分。
自己有想过用字典来处理，但是组合商品的数量有多有少，还要根据组合的数量进行向下插入。
没有头绪，求解救
图一.原始订单

原始订单

图二.商品基础信息

商品基础数据

图三.最终效果

需要达到的效果

订单拆分.zip (9.41 KB, 下载次数: 19)

2018-8-8 18:04 上传

点击文件名下载附件

不知道为什么

看你附件模拟结果，是应该根据 商家SKU 进行拆分把

不知道为什么

如图

不知道为什么

参考

luyin

不知道为什么 发表于 2018-8-8 18:39
参考

1、订单表记录多的话就会下标越界
2、当DATA不等于1时，仍会按1来计算

xiangbaoan

Sub test()'仅供参考，针对所提供的附件
Dim d As Object, ar, br, r&, y%
Set d = CreateObject("scripting.dictionary")
With Sheets(2)
    ar = .[a1].CurrentRegion
    For r = 2 To UBound(ar)
        If Len(ar(r, 1)) Then d(ar(r, 1)) = r
    Next
    d(r) = r
    For i = 0 To d.Count - 2
        Set d(d.keys()(i)) = .Cells(d.items()(i), 1).Resize(d.items()(i + 1) - d.items()(i), UBound(ar, 2))
    Next
End With
With Sheets(1)
    br = .[a1].CurrentRegion
    If UBound(br) > 1 Then
        .[a15].Resize(8765, 4).Clear
        y = 15
        For r = 2 To UBound(br)
            If d.exists(br(r, 1)) Then
                d(br(r, 1)).Copy .Range("a" & y)
                y = .[b65536].End(3).Row + 1
            End If
        Next
    End If
End With
Set d = Nothing
End Sub

任飘渺

Sub tt()
    Dim arrOrder, dic As Object, arrData, i As Long, n As Integer
    Dim brr()
    n = 0
    Set dic = CreateObject("scripting.dictionary")
    arrOrder = Sheet1.Range("a1").CurrentRegion.Value
    arrData = Sheet2.Range("a1").CurrentRegion.Value
    ReDim brr(1 To UBound(arrData), 1 To 4)
    For i = 2 To UBound(arrOrder)
        dic(arrOrder(i, 1)) = ""
    Next i
    For i = 2 To UBound(arrData)
        If arrData(i, 1) = "" Then arrData(i, 1) = arrData(i - 1, 1)
    Next i
    For i = 2 To UBound(arrData)
        If dic.exists(arrData(i, 1)) = True Then
            n = n + 1
            brr(n, 1) = arrData(i, 1)
            brr(n, 2) = arrData(i, 2)
            brr(n, 3) = arrData(i, 3)
            brr(n, 4) = arrData(i, 4)
        End If
    Next i
    For i = n To 2 Step -1
        If i = 1 Then Exit For
        If brr(i, 1) = brr(i - 1, 1) Then brr(i, 1) = ""
    Next i
    With Sheet1
        .Range("B:B").NumberFormatLocal = "@"
        .Range("a23").Resize(n, 4) = brr
   End With
End Sub

luyin

xiangbaoan 发表于 2018-8-9 10:17
Sub test()'仅供参考，针对所提供的附件
Dim d As Object, ar, br, r&, y%
Set d = CreateObject("script ...

改订单表和DATA中的数量，都没有反应

luyin

任飘渺 发表于 2018-8-9 10:37
Sub tt()
    Dim arrOrder, dic As Object, arrData, i As Long, n As Integer
    Dim brr()

改订单表和DATA中的数量，都没有反应

xiangbaoan

luyin 发表于 2018-8-9 15:32
改订单表和DATA中的数量，都没有反应

Sub test() '全是猜测的，不对就算了
Dim d1 As Object, d2 As Object, ar, br, r&, i%, y%
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets(1)
    br = .[a1].CurrentRegion
    If UBound(br) > 1 Then
        For r = 2 To UBound(br)
            d1(br(r, 1)) = br(r, 4)
        Next
    End If
End With
With Sheets(2)
    ar = .[a1].CurrentRegion
    For r = 2 To UBound(ar)
        If Len(ar(r, 1)) Then d2(ar(r, 1)) = r
    Next
    d2(r) = r
    For i = 0 To d2.Count - 2
        If d1.exists(d2.keys()(i)) Then .Cells(d2.items()(i), 4).Resize(d2.items()(i + 1) - d2.items()(i)) = d1(d2.keys()(i))
        Set d2(d2.keys()(i)) = .Cells(d2.items()(i), 1).Resize(d2.items()(i + 1) - d2.items()(i), UBound(ar, 2))
    Next
End With
With Sheets(1)
    br = .[a1].CurrentRegion
    If UBound(br) > 1 Then
        .[a15].Resize(8765, 4).Clear
        y = 15
        For r = 2 To UBound(br)
            If d2.exists(br(r, 1)) Then
                d2(br(r, 1)).Copy .Range("a" & y)
                y = .[b65536].End(3).Row + 1
            End If
        Next
    End If
End With
Set d1 = Nothing
Set d2 = Nothing
End Sub