把数据表的内容按模板导入到新表

3190496160

入库单输出.rar (19.01 KB, 下载次数: 19)

2023-3-27 10:46 上传

点击文件名下载附件

lushang2018

ykcbf1100

附件仅供参考。。。

aifeiqi

3190496160 发表于 2023-3-27 10:46

谢谢上面几位老师的指教，你这个JH-230202-130，有8行，超过5行，后面的三行就没显示了。

a18b88

仅供参考，附件： 入库单输出（测试）.rar (18.26 KB, 下载次数: 7)

2023-3-27 15:49 上传

点击文件名下载附件

3190496160

aifeiqi 发表于 2023-3-27 15:03
谢谢上面几位老师的指教，你这个JH-230202-130，有8行，超过5行，后面的三行就没显示了。

有一句代码确实有点问题，
Sub test()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim br(), cr()
With Sheets("数据库")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 7 Then MsgBox "数据库为空！": End
    ar = .Range("a1:t" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
If (r - 1) / 5 = Int(r - 1) / 5 Then
    sl = (r - 1) / 5
Else
    sl = Int(r - 1) / 5 + 1
End If
With Sheets("模板")
     rs = .Cells(Rows.Count, 3).End(xlUp).Row
    If rs >= 17 Then .Rows("17:" & rs).Delete
    .Range("B3,C4:C6,H4:H5,B8:I12") = Empty
    m = 17
    For i = 2 To sl + d.Count
        .Rows("1:16").Copy .Cells(m, 1)
        m = m + 16
    Next i
    m = 8
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To 8)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 4)) = k Then
                rq = ar(i, 3)
                bh = ar(i, 17)
                gys = ar(i, 6)
                dh = ar(i, 20)
                dz = ar(i, 7)
                n = n + 1
                For j = 10 To 16
                    br(n, j - 9) = ar(i, j)
                Next j
                br(n, 8) = ar(i, 18)
            End If
        Next i
        If n <= 5 Then
            .Cells(m - 5, 2) = rq
            .Cells(m - 4, 3) = bh
            .Cells(m - 4, 8) = k
            .Cells(m - 3, 3) = gys
            .Cells(m - 3, 8) = dh
            .Cells(m - 2, 3) = dz
            .Cells(m, 2).Resize(n, UBound(br, 2)) = br
            m = m + 16
        Else
            For i = 1 To n Step 5
                .Cells(m - 5, 2) = rq
                .Cells(m - 4, 3) = bh
                .Cells(m - 4, 8) = k
                .Cells(m - 3, 3) = gys
                .Cells(m - 3, 8) = dh
                .Cells(m - 2, 3) = dz
                w = m - 1
                For s = i To i + 4
                    w = w + 1
                    For j = 1 To 8
                        .Cells(w, j + 1) = br(s, j)
                    Next j
                Next s
                m = m + 16
            Next i
        End If
    Next k
    ms = .Cells(Rows.Count, 3).End(xlUp).Row
    For i = ms To 8 Step -1
        If InStr(.Cells(i, 1), "日期") > 0 And Trim(.Cells(i, 2)) <> "" Then
            xh = i
            Exit For
        End If
    Next i
    If xh <> "" Then .Rows(xh + 14 & ":" & ms).Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

已修改
入库单输出.rar (19.05 KB, 下载次数: 16)

2023-3-27 16:43 上传

点击文件名下载附件

jjmysjg

蓝桥玄霜 发表于 2023-3-27 10:12
入库单的例子：

数据库数据增加，写入的模板超出5行了，麻烦大师看看