订单条目不重复拆分

业务员

半百 发表于 2023-3-24 11:37
试试。。

订单2只有两个药品才是对的。否者我把订单1和订单2都上传平台，那销量就超过实际了，多了

业务员

谢谢各位老师。有一些老师的代码虽然与需求不同。但是都是非常值得学习的。谢谢啦。今日花朵已经用完。我下论坛，仔细去学习代码了

cjc209

ykcbf1100 发表于 2023-3-24 11:39
那是这意思？

还有点没有对 就是最后一个订单总要带过来一个重复2次的

ykcbf1100

cjc209 发表于 2023-3-24 11:47
还有点没有对 就是最后一个订单总要带过来一个重复2次的

那再看看吧。

cjc209

增加一列辅助列就好搞 按辅助列中的出现次数分表就对了

业务员

ykcbf1100 发表于 2023-3-24 11:39
那是这意思？

我用了实际数据去测试，有一些问题，生成了三个分表。条目加起来大于总表了。

业务员

半百 发表于 2023-3-24 11:37
试试。。
Resize(1, 4)里边的4可以改为3或你表中实际的列数。

谢谢老师，很好的代码，我都不用改，直接把配送商放进去，完美。

ykcbf1100

业务员 发表于 2023-3-24 11:51
我用了实际数据去测试，有一些问题，生成了三个分表。条目加起来大于总表了。

你先用半百老师的代码吧。
哪个能解决问题就用哪个。

cjc209

这样就不需要做辅助列了
Sub test()
    Set dic = CreateObject("scripting.dictionary")
    Dim arr, brr()
    arr = Sheets(1).UsedRange
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim Preserve arr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
    For i = 2 To UBound(arr)
        关键字 = arr(i, 1)
        If Not dic.exists(关键字) Then
            dic(关键字) = 1
            arr(i, UBound(arr, 2)) = dic(关键字)
        Else
            dic(关键字) = dic(关键字) + 1
            arr(i, UBound(arr, 2)) = dic(关键字)
        End If
    Next
    dic.RemoveAll
    For i = 1 To UBound(arr)
        dic(arr(i, UBound(arr, 2))) = ""
    Next
    For Each v In dic.keys
        If v > 0 Then
            l = 0
            For i = 1 To UBound(arr)
                If arr(i, UBound(arr, 2)) = v Then
                    l = l + 1
                    For j = 1 To UBound(arr, 2) - 1
                        brr(l, j) = arr(i, j)
                    Next
                End If
            Next
            Sheets.Add
            ActiveSheet.Name = "订单" & v
            ActiveSheet.[a1:c1] = Array("名称", "单位", "数量")
            ActiveSheet.[a2].Resize(l, UBound(brr, 2)) = brr
        End If
    Next
Set dic = Nothing
End Sub

cjc209

完整代码
Sub test()
    Set dic = CreateObject("scripting.dictionary")
    Dim arr, brr()
    arr = Sheets("Sheet1").[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim Preserve arr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
    Application.DisplayAlerts = False
    For Each sht In Sheets
        If sht.Name <> "Sheet1" Then sht.Delete
    Next sht
    For i = 2 To UBound(arr)
        关键字 = arr(i, 1)
        If Not dic.exists(关键字) Then
            dic(关键字) = 1
            arr(i, UBound(arr, 2)) = dic(关键字)
        Else
            dic(关键字) = dic(关键字) + 1
            arr(i, UBound(arr, 2)) = dic(关键字)
        End If
    Next
    dic.RemoveAll
    For i = 1 To UBound(arr)
        dic(arr(i, UBound(arr, 2))) = ""
    Next
    For Each v In dic.keys
        If v > 0 Then
            l = 0
            For i = 1 To UBound(arr)
                If arr(i, UBound(arr, 2)) = v Then
                    l = l + 1
                    For j = 1 To UBound(arr, 2) - 1
                        brr(l, j) = arr(i, j)
                    Next
                End If
            Next
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = "订单" & v
            ActiveSheet.[a1:c1] = Array("名称", "单位", "数量")
            ActiveSheet.[a2].Resize(l, UBound(brr, 2)) = brr
        End If
    Next
    Sheets("Sheet1").Activate
    Application.DisplayAlerts = True
End Sub