用VBA将箱贴数据填充到模板中实现效果(求大神指点)

q1342871134

各位大佬，看看用VBA能否实现将箱贴数据中的信息填充到箱贴模板中对应的位置，直到完成所有数据，最终生成图三的效果，学习下，非常感谢！！！

清风竹-

请看附件。

3190496160

Sub 生成箱贴()
Application.ScreenUpdating = False
Dim ar As Variant
With Sheets("箱贴数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "箱贴数据为空！": End
    ar = .Range("a1:i" & r)
End With
h = r - 1
If h / 2 = Int(h / 2) Then
    gs = h / 2
Else
    gs = Int(h / 2) + 1
End If
With Sheets("模板")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs >= 11 Then .Rows("11:" & rs).Delete
    Range("A3:C3,B4:C9,F3:G9").ClearContents
    m = 11
    For i = 2 To gs
        .Rows("1:10").Copy .Cells(m, 1)
        m = m + 10
    Next i
    m = 3
    For i = 2 To UBound(ar) Step 2
        For j = 1 To 3
            .Cells(m, j) = ar(i, j)
        Next j
        .Cells(m + 1, 2) = ar(i, 9)
        .Cells(m + 2, 2) = ar(i, 4)
        For j = 6 To 8
            .Cells(m + j - 3, 2) = ar(i, j)
        Next j
        .Cells(m + 6, 2) = ar(i, 5)
        
        If i + 1 <= UBound(ar) Then
            For j = 1 To 3
                .Cells(m, j + 4) = ar(i + 1, j)
            Next j
            .Cells(m + 1, 6) = ar(i + 1, 9)
            .Cells(m + 2, 6) = ar(i + 1, 4)
            For j = 6 To 8
                .Cells(m + j - 3, 6) = ar(i + 1, j)
            Next j
            .Cells(m + 6, 6) = ar(i + 1, 5)
        End If
        m = m + 10
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

箱贴.rar (22.9 KB, 下载次数: 9)

2024-2-19 10:23 上传

点击文件名下载附件

q1342871134

清风竹- 发表于 2024-2-18 17:17
请看附件。

是这个，太厉害了，大佬