按生产单号拆分出现越界问题求改代码

jaxpqh

　　这是我上一个帖子（https://club.excelhome.net/thread-1691403-1-1.html?_dsign=aad8323c）的延续，我需要按生产单号拆分表格，原来的要求确实有些复杂，我改变了思路，按每个生产单号一个工作簿进行拆分，同一个月的生产单放在同一个文件夹，而且实现了自动插入图片。如果一个生产单号只有一行内容，我可以拆分出来。现在的问题是，一个生产单号有多行内容时，需要以货品名称来区分，拆分后的表格放在同一工作簿的不同工作表，但写出来的代码运行出错，下标越界，找不出是什么原因。请哪位大师帮我修改一下代码。先谢谢了！

limonet

不能SQL，等其他大佬的数组与字典法。

quqiyuan

这是我的理解，仅供参考

3190496160

到我的主题里面去找找，有一个拆分工具可以选择主拆分关键字和次拆分关键字拆分，可以满足你的需求

3190496160

Sub 批量拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Worksheets("模板")
lj = ThisWorkbook.Path & "\生产单\"
tt = Timer
With ThisWorkbook.Worksheets("总表")
    .AutoFilterMode = False
    r = .Cells(.Rows.Count, 4).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Range("a1").Resize(r, c)
End With
For i = 2 To UBound(arr)
    If arr(i, 3) <> "" Then
        If IsDate(arr(i, 3)) Then
            nf = Year(arr(i, 3))
            yf = Month(arr(i, 3))
            dc(nf & "|" & yf) = ""
        End If
    End If
Next i
For Each kc In dc.keys
    rr = Split(kc, "|")
    ny = rr(0)
    yf = rr(1)
    wjj_1 = lj & nf & "年"
    wjj_2 = lj & nf & "年\" & yf & "月"
    If Not fso.folderexists(wjj_1) Then fso.CreateFolder wjj_1
    If Not fso.folderexists(wjj_2) Then fso.CreateFolder wjj_2
Next kc
For i = 2 To UBound(arr)
    If arr(i, 1) <> "" Then
        If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
        d(arr(i, 1))(arr(i, 7)) = i
    End If
Next i
rr = Array([b3].Address, [e3].Address, [h3].Address, [b4].Address, [e4].Address, [h4].Address, [b5].Address, [e5].Address, [h5].Address, [c6].Address, [c7].Address, [c8].Address, [h8].Address)
For Each k In d.keys
    m = 0
    For Each kk In d(k).keys
        xh = d(k)(kk)
        nf = Year(arr(xh, 3))
        yf = Month(arr(xh, 3))
        m = m + 1
        If m = 1 Then
            sh.Copy
            Set wb = ActiveWorkbook
        ElseIf m > 1 Then
            sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
        End If
        With wb.ActiveSheet
            .Name = kk
            For j = 1 To 13
                .Range(rr(j - 1)) = arr(xh, j)
            Next j
            h = 9
            For j = 14 To 18 Step 2
                h = h + 1
                .Cells(h, 2) = arr(xh, j)
                .Cells(h, 7) = arr(xh, j + 1)
            Next j
            h = 13
            For j = 20 To 24 Step 2
                h = h + 1
                .Cells(h, 2) = arr(xh, j)
                .Cells(h, 7) = arr(xh, j + 1)
            Next j
            h = 17
            For j = 26 To 30 Step 2
                h = h + 1
                .Cells(h, 2) = arr(xh, j)
                .Cells(h, 7) = arr(xh, j + 1)
            Next j
            h = 21
            For j = 32 To 35 Step 1
                h = h + 1
                .Cells(h, 2) = arr(xh, j)
            Next j
            End With
        Next kk
    wb.SaveAs Filename:=lj & nf & "年\" & yf & "月\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "导出完毕，用时：" & Format(Timer - tt, "#0.00") & " 秒", , "棋子提示"
End Sub

3190496160

拆分生产单.rar (1.17 MB, 下载次数: 7)

2024-5-11 17:21 上传

点击文件名下载附件

3190496160

代码仅仅提供一个解决问题的思路，插入图片的代码没有写，自己添加吧，供参考，

jaxpqh

3190496160 发表于 2024-5-11 17:20
Sub 批量拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

　　老师的代码高大上，可我看不太懂！