同类合并+自动编号，求大腿帮忙改改，万分感谢！

浮生若梦几许痴_

来个大腿，帮忙改改代码，万分感谢！！！

要实现的目标：
1、订单表中根据Item相同的合并数量到计划表中；
2、在计划表中自动生成计划单号（日期yymmdd+三位序号）；
3、将计划单号返回到对应的销售订单；
4、订单表有数据新增时，有计划单号的不参与排产；
5、两个表都保留原来的数据记录；

3190496160

Sub paichan()
Dim ar As Variant
Dim br()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("订单")
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     .Range("j1:j" & rs) = Empty
     ar = .Range("a1:j" & rs)
     ReDim br(1 To UBound(ar), 1 To 4)
     For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" Then
            If Trim(ar(i, 9)) = "" Then
                d(Trim(ar(i, 3))) = ""
            End If
        End If
    Next i
    If d.Count = 0 Then MsgBox "没有需要安排的数据": Exit Sub
    For Each k In d.keys
        m = m + 1
        For i = 2 To UBound(ar)
            If Trim(ar(i, 3)) = k Then
                If Trim(ar(i, 9)) = "" Then
                    ar(i, 9) = Format(ar(i, 2), "yyyymmdd") & Format(m, "000")
                    ar(i, 10) = "新"
                End If
            End If
        Next i
    Next k
    .[i1].Resize(UBound(ar), 1) = Application.Index(ar, 0, 9)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 3)) <> "" And Trim(ar(i, 10)) = "新" Then
        t = dc(Trim(ar(i, 3)))
        If t = "" Then
            kk = kk + 1
            dc(Trim(ar(i, 3))) = kk
            t = kk
            br(kk, 1) = ar(i, 9)
            br(kk, 2) = ar(i, 2)
            br(kk, 3) = ar(i, 3)
        End If
        br(t, 4) = br(t, 4) + ar(i, 4)
    End If
Next i
With Sheets("生产计划")
    r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    .Cells(r, 1).Resize(kk, 4) = br
End With
MsgBox "ok!"
End Sub

3190496160

订单排产.rar (22.98 KB, 下载次数: 11)

2022-5-30 10:19 上传

点击文件名下载附件

3190496160

原来的代码他繁琐，以这个为准
Sub paichan()
Dim ar As Variant
Dim br()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("订单")
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     .Range("j1:j" & rs) = Empty
     ar = .Range("a1:j" & rs)
     ReDim br(1 To UBound(ar), 1 To 4)
     For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" Then
            If Trim(ar(i, 9)) = "" Then
                t = d(Trim(ar(i, 3)))
                If t = "" Then
                    k = k + 1
                    d(Trim(ar(i, 3))) = k
                    t = k
                    br(k, 1) = ar(i, 9)
                    br(k, 2) = ar(i, 2)
                    br(k, 3) = ar(i, 3)
                End If
                ar(i, 9) = Format(ar(i, 2), "yyyymmdd") & Format(t, "000")
                br(t, 1) = ar(i, 9)
                br(t, 4) = br(t, 4) + ar(i, 4)
            End If
        End If
    Next i
    .[i1].Resize(UBound(ar), 1) = Application.Index(ar, 0, 9)
End With
With Sheets("生产计划")
    r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    .Cells(r, 1).Resize(k, 4) = br
End With
MsgBox "ok!"
End Sub

3190496160

简化了代码
订单排产.rar (22.75 KB, 下载次数: 33)

2022-5-30 11:39 上传

点击文件名下载附件

浮生若梦几许痴_

太感谢了！大部分的功能都实现了。

浮生若梦几许痴_

3190496160 发表于 2022-5-30 11:39
简化了代码

太感谢大神了！大部分的功能都实现了。计划单号能不能为现在的时间（Now）+序列号，不用管订单时间。

另外，没有新增数据的时候，执行代码有错误。帮忙再看看，谢谢！

3190496160

时间问题，修改一下这句代码就行了吧，
ar(i, 9) = Format(ar(i, 2), "yyyymmdd") & Format(t, "000")
没有新增数据，判断一下k，如果k为空则强制结束就行了
不是啥都呀伸手的吧

浮生若梦几许痴_

3190496160 发表于 2022-5-30 19:20
时间问题，修改一下这句代码就行了吧，
ar(i, 9) = Format(ar(i, 2), "yyyymmdd") & Format(t, "000")
没 ...

哈哈，谢谢大神，主要基础太差，我自己琢磨琢磨。