订单条目不重复拆分

业务员

cjc209 发表于 2023-3-24 13:06
完整代码
Sub test()
    Set dic = CreateObject("scripting.dictionary")

谢谢，今天花朵用完了

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr, i&, j&, r&, n&, dic As Object, vKey, strFileName$
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion
    For i = 2 To UBound(ar)
        vKey = ar(i, 1)
        dic(vKey) = dic(vKey) & "," & i
        cr = Split(dic(vKey), ",")
        n = IIf(UBound(cr) > n, UBound(cr), n)
    Next i
   
    For i = 1 To n
        br = ar: r = 1
        With Workbooks.Add
            strFileName = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, ".") - 1) & "-" & i
            For Each vKey In dic.keys
                cr = Split(dic(vKey), ",")
                If UBound(cr) >= i Then
                    r = r + 1
                    For j = 1 To UBound(ar, 2)
                        br(r, j) = ar(cr(i), j)
                    Next j
                End If
            Next
            With .Sheets(1).[A1].Resize(r, UBound(br, 2))
                .Value = ar
                .Borders.LineStyle = xlContinuous
                .EntireColumn.AutoFit
                .EntireRow.AutoFit
            End With
            .SaveAs strFileName
            .Close
        End With
    Next i
   
    Set dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

业务员

cjc209 发表于 2023-3-24 13:06
完整代码
Sub test()
    Set dic = CreateObject("scripting.dictionary")

Sub test()
Set d = CreateObject("scripting.dictionary")
Dim brr(1)
arr = Sheets(1).UsedRange
For i = 2 To UBound(arr)
    d(arr(i, 1)) = d(arr(i, 1)) + 1
    n = d(arr(i, 1))
    If m < n Then
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Name = m + 1
            .[a1:d1] = Application.Index(arr, 1, 0)
            .Cells(2, 1).Resize(1, 4) = Application.Index(arr, i, 0)
        End With
        m = m + 1
    Else
        r = Sheets(n + 1).Cells(Rows.Count, 1).End(3).Row + 1
        Sheets(n + 1).Cells(r, 1).Resize(1, 4) = Application.Index(arr, i, 0)
    End If
Next
End Sub
这个看上去很简洁

gwjkkkkk

参与 一下。。。

业务员

gwjkkkkk 发表于 2023-3-24 20:38
参与 一下。。。

有点问题，哈哈，多加几个数据测试就知道了。
Sub test()
Set d = CreateObject("scripting.dictionary")
Dim brr(1)
arr = Sheets(1).UsedRange
For i = 2 To UBound(arr)
    d(arr(i, 1)) = d(arr(i, 1)) + 1
    n = d(arr(i, 1))
    If m < n Then
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Name = m + 1
            .[a1:d1] = Application.Index(arr, 1, 0)
            .Cells(2, 1).Resize(1, 4) = Application.Index(arr, i, 0)
        End With
        m = m + 1
    Else
        r = Sheets(n + 1).Cells(Rows.Count, 1).End(3).Row + 1
        Sheets(n + 1).Cells(r, 1).Resize(1, 4) = Application.Index(arr, i, 0)
    End If
Next
End Sub

gwjkkkkk

业务员 发表于 2023-3-24 20:54
有点问题，哈哈，多加几个数据测试就知道了。
Sub test()
Set d = CreateObject("scripting.dictionary ...

这个不是我写的吧，你再看看。。。

业务员

gwjkkkkk 发表于 2023-3-24 22:05
这个不是我写的吧，你再看看。。。

我贴的是半百老师的，我测试无问题。您的代码有些小问题呢

zxsea_7426

凑个热闹，正好继续练练手:

测试请保留备份，本代码第一步会删除工作表只保留一个工作表

笨鸟飞不高

订单分拆.zip (17.39 KB, 下载次数: 3)

2023-3-25 09:01 上传

点击文件名下载附件

准提部林

Sub TEST_A1()
Dim Arr, xD, T$, i&, R, N%
Set xD = CreateObject("scripting.dictionary")
With Sheets(1).[a1].CurrentRegion
     Arr = .Value
     For i = 2 To UBound(Arr)
         T = Arr(i, 1): xD(T) = xD(T) + 1: N = xD(T)
         If xD(N) = 0 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = N
         xD(N) = xD(N) + 1
         If xD(N) = 1 Then .Rows(1).Copy Sheets(N & "").[a1]
        .Rows(i).Copy Sheets(N & "").Cells(xD(N) + 1, 1)
    Next
End With
End Sub