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

aifeiqi

请把数据库表的内容按模板导入到新表(同一工作表)，一张A4纸上按模板排3份入库单格式。

ykcbf1100

没说清楚啊，是按哪一列来拆分数据的？
既然求助，就要说清楚，不要让写代码的人去猜，万一猜错了，又得重新写，大家都烦。

liulang0808

建议楼主结合附件内容模拟下结果
到底几行数据合并处理，还是一行对应一个区域？

另外论坛相关案例也不少，可以参考的

aifeiqi

ykcbf1100 发表于 2023-3-27 09:10
没说清楚啊，是按哪一列来拆分数据的？
既然求助，就要说清楚，不要让写代码的人去猜，万一猜错了，又得重 ...

对不起，按单号拆分，D列

ZHLK

Sub demo()
Dim sht As Worksheet
Sheets("模板").Copy After:=Sheets(2)
Set sht = ActiveSheet
a = 2
Do While a < Range("a65320").End(xlUp).Row + 1
    For i = 1 To 3
        '填日期
        sht.Cells((i - 1) * 16 + 3, 3) = Sheets("数据库").Cells(a, 3)
        '合同编号
        sht.Cells((i - 1) * 16 + 4, 3) = Sheets("数据库").Cells(a, 20)
        '后续.........
        '----------------------------------
        a = a + 1
    Next i
   
    sht.PrintPreview

Loop

Application.DisplayAlerts = False
    sht.Delete
Application.DisplayAlerts = True


End Sub

ykcbf1100

aifeiqi 发表于 2023-3-27 09:15
对不起，按单号拆分，D列

看吧，我就猜错了，我还以为是供应商那一列。

3190496160

如果同一个单号超过4行数据呢？？？？

aifeiqi

3190496160 发表于 2023-3-27 09:53
如果同一个单号超过4行数据呢？？？？

超过5行就要换下一个入库单继续打印了，入库单号码相同，反正每张入库单最多5行吧

蓝桥玄霜

入库单的例子：

3190496160

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 - 2 & ":" & ms).Delete
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub