VBA识别内容分隔并代入打印模板A4打印

PecosHo

因公司打包商品需要打印装箱明细，如附件表格
1、在表1中录入条码等商品信息，如何通过一个VBA按钮实现判断BOX001等类似于字母开头带数字的标识为分隔
2、将截止到下一个分隔出现的地方为一个输出打印，并判断同箱号以内是否有超出十个（每次输出最多十行，打印模板最多十行）
3、如超出就顺移至下一个继续打印且一样不超出十行，并同时把箱号输出到打印模板左上角处
4、最终打印完成后需要清空打印模板中的数据和表格，只需要保留第一个且为空白表
5、打印模板为A4纸张且左右布局，每箱序号打印时超十个的要顺接序号

数据录入表


数据代入打印模板（需要的打印效果）


打印后留空打印模板


之前求助贴地址：https://club.excelhome.net/thread-1642929-1-1.html

有一大神基本实现，只是因为需要打印的模板为A4大小且左右布局，就没下文了，跪求大神们再支下招！万分感谢！！！

工作簿1.zip (15.78 KB, 下载次数: 13)

2023-2-24 20:06 上传

点击文件名下载附件

罗达

不难，先留痕迹，如果周末没事就来练练手。

PecosHo

罗达 发表于 2023-2-24 20:51
不难，先留痕迹，如果周末没事就来练练手。

感谢，看到了希望，期待

wang-way

行高列宽自己调

1. Public Sub wang_way()
   
2.     Dim Wb As Workbook
   
3.     Dim Sht As Worksheet
   
4.     Dim oSht As Worksheet
   
5.     Dim rng As Range
   
6.     Dim des As Range
   
7.     Set Wb = Application.ThisWorkbook
   
8.     Set Sht = Wb.Worksheets("Sheet1")
   
9.     Set oSht = Wb.Worksheets("打印")
   
10.     With oSht
    
11.         Set rng = .Range("A1:F13")
    
12.         c = rng.Columns.Count
    
13.         r = rng.Rows.Count
    
14.         .UsedRange.Offset(r).Clear
    
15.         .UsedRange.Offset(, c).Clear
    
16.     End With
    
17.     With Sht
    
18.         endrow = .Cells(.Cells.Rows.Count, 3).End(xlUp).Row
    
19.         For i = 2 To endrow
    
20.             If .Cells(i, 3).Value Like "BOX###" Then
    
21.                 n = n + 1
    
22.                 p = (n - 1) Mod 2 + 1
    
23.                 q = Int((n - 1) / 2) + 1
    
24.                 l = (p - 1) * c + 1
    
25.                 h = (q - 1) * r + 1
    
26.                 Debug.Print n, "纵", p, "横", q, , , , "列", l, "行", h
    
27.                 rng.Copy oSht.Cells(h, l)
    
28.                 oSht.Cells(h, l).Resize(1, 2).Merge
    
29.                 oSht.Cells(h, l).Value = .Cells(i, 3).Value
    
30.                 x = i + 1
    
31.                 k = 0
    
32.                 Do While .Cells(x, 4).Value <> ""
    
33.                     k = k + 1
    
34.                     oSht.Cells(h + k + 1, l).Value = k
    
35.                     oSht.Cells(h + k + 1, l + 1).Value = .Cells(x, 3).Value
    
36.                     oSht.Cells(h + k + 1, l + 2).Value = .Cells(x, 4).Value
    
37.                     oSht.Cells(h + k + 1, l + 3).Value = .Cells(x, 5).Value
    
38.                     oSht.Cells(h + k + 1, l + 4).Value = .Cells(x, 6).Value
    
39.                     x = x + 1
    
40.                 Loop
    
41.             End If
    
42.         Next i
    
43.     End With
    
44. End Sub

复制代码

罗达

PecosHo 发表于 2023-2-24 20:56
感谢，看到了希望，期待

我的代码有点啰嗦，仅供参考 工作簿4签打印.rar (27.05 KB, 下载次数: 18)

2023-2-25 15:41 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub test()
Dim ar, br(), cr, i&, j&, k&, r&, iRowCount&, y&, x&, Rng As Range

    Application.ScreenUpdating = False
    cr = Array("No.", "国际条码", "型号", "名称", "数量")
    Set Rng = Sheets(2).[A1:E12]
    With Range([C2], Cells(Rows.Count, "F").End(3))
        ar = .Value
        For i = 1 To UBound(ar)
            If InStr(ar(i, 1), "BOX") Then
                r = r + 1
                ReDim Preserve br(1 To r)
                br(r) = i
            End If
        Next i
        r = UBound(ar)
        For i = 1 To UBound(br)
            If i = UBound(br) Then
                iRowCount = r - br(i) + 1
            Else
                iRowCount = br(i + 1) - br(i)
            End If
            br(i) = .Cells(br(i), 1).Resize(iRowCount, 4)
            ReDim ar(1 To iRowCount + 1, 1 To 5)
            ar(1, 1) = br(i)(1, 1)
            For j = 0 To UBound(cr)
                ar(2, j + 1) = cr(j)
            Next j
            For j = 2 To UBound(br(i))
                ar(j + 1, 1) = j - 1
                For k = 1 To UBound(br(i), 2)
                    ar(j + 1, k + 1) = br(i)(j, k)
                Next k
            Next j
            br(i) = ar
            br(i) = cutArray1(br(i), 10, 2)
        Next i
    End With

    r = 0
    With Workbooks.Add
        With .Sheets(1)
            For i = 1 To UBound(br)
                For j = 1 To UBound(br(i))
                    r = r + 1
                    y = ((-Int(-r / 2)) - 1) * 13 + 1
                    x = IIf(r Mod 2 = 0, 7, 1)
                    Rng.Copy .Cells(y, x)
                    With .Cells(y, x).Resize(12, 5)
                        .HorizontalAlignment = xlCenter
                        .Borders.LineStyle = xlContinuous
                        .Font.Bold = True
                        .RowHeight = 42.5
                        .EntireColumn.AutoFit
                        .Columns(4).ColumnWidth = 19
                    End With
                    With .Cells(y, x).Resize(UBound(br(i)(j)), 5)
                        .Value = br(i)(j)
                    End With
                Next j
            Next i
        End With
    End With

    Set Rng = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
Function cutArray1(ar, iCutNum&, Optional iHeader& = 1) As Variant
    Dim brr(), crr, i&, j&, iPosRow&, r&, k&
    ar = Application.Transpose(Application.Transpose(ar))
    For i = iHeader + 1 To UBound(ar) Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > UBound(ar), (UBound(ar) - iHeader) Mod iCutNum, iCutNum)
        ReDim crr(1 To iPosRow + iHeader, 1 To UBound(ar, 2))
        For j = iHeader + 1 To UBound(crr)
            For k = 1 To UBound(crr, 2)
               crr(j, k) = ar(i - 1 + j - iHeader, k)
            Next k
        Next j
        For j = 1 To iHeader
            For k = 1 To UBound(crr, 2)
                crr(j, k) = ar(j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve brr(1 To r)
        brr(r) = crr
    Next i
    cutArray1 = brr
End Function

gwjkkkkk

PecosHo 发表于 2023-2-24 20:56
感谢，看到了希望，期待

请楼主参考附件。。。

PecosHo

wang-way 发表于 2023-2-24 22:33
行高列宽自己调

感谢感谢，很有参考价值

PecosHo

罗达 发表于 2023-2-25 15:41
我的代码有点啰嗦，仅供参考

不啰嗦，就是可能我表达错了，是我想要的效果，但打印是A4横向两个标签，不是四个，而且，当不足两个标签时，另一半A4空白，包括表格什么都不要，以便另一个半张能再使用，本来想自己修改一下，但无耐没那本事，还麻烦帮改进改进，谢谢！如果不是以BOX开头，是别的字母或纯数字了，还能识别不？

1


2

PecosHo

gwjkkkkk 发表于 2023-2-25 17:20
Option Explicit
Sub test()
Dim ar, br(), cr, i&, j&, k&, r&, iRowCount&, y&, x&, Rng As Range

感谢大神，试了一下，如果添加或更多时，会卡很久，但很有参考价值，非常感谢，谢谢