提取数据并按要求生成打印表格

大翔象

点击按钮后，根据sheet页“店舗”的数据，在sheet页“みやき用紙（数式有）”生成A4大小的打印页，sheet页“店舗”的每一行数据都会生成一页新的打印页

大翔象

1行数据会生成 四条对应的打印格
数据对应关系如下

（1)对应D列

(2) 由B列数据 + 年月日 + 0001 （以此类推 1行生成四条 其他的就是 0002 0003 0004 下一行数据还是从0001开始）构成 并且 转换为对应的128条形码（model1里有生成128条形码的方法）  
（3）C列
（4）默认值：/
（5）默认值：みやきセンター
（6）B列

ykcbf1100

日文看不懂，略过。。。

大翔象

ykcbf1100 发表于 2024-8-23 14:25
日文看不懂，略过。。。

不好意思，第一次发帖没经验，还没详细介绍还没发完

大翔象

ykcbf1100 发表于 2024-8-23 14:25
日文看不懂，略过。。。

大佬能帮忙看一下吗

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br, cr, i&, j&, tRng As Range, iPosRow&, iMsg&
   
    Application.ScreenUpdating = False
   
    ar = Worksheets("店舗").[B1].CurrentRegion.Value
    Set tRng = Sheets("みやき用紙（数式有）").[A1:K31]
    br = [{"B1","H1","B18","H18"}]
    cr = [{"A5","G5","A22","G22"}]
   
    With Worksheets(3)
        .Cells.Delete
        For i = 1 To UBound(ar)
            iPosRow = (i - 1) * 32 + 1
            rngCopyToSame tRng, .Cells(iPosRow, 1)
            If i > 1 Then .HPageBreaks.Add Before:=.Cells(iPosRow, 1)
            With .Cells(iPosRow, 1)
                For j = 1 To UBound(br)
                    .Range(br(j)).Value = "'" & Format(ar(i, 1), "00000") & Format(Date, "YYMMDD") & Format(j, "0000")
                Next j
                For j = 1 To UBound(cr)
                    .Range(cr(j)).Value = ar(i, 2)
                    .Range(cr(j)).Offset(1).Offset(, 4).Value = ar(i, 1)
                Next j
            End With
        Next i
        .Activate
        iMsg = MsgBox("是否预览", vbYesNo + vbInformation, "???")
        If iMsg = vbYes Then .PrintPreview
        ActiveWindow.ScrollRow = 1
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

大翔象

gwjkkkkk 发表于 2024-8-23 21:13
Option Explicit
Sub test1()
    Dim ar, br, cr, i&, j&, tRng As Range, iPosRow&, iMsg&

大佬我执行了一下，有部分条形码都堆在了第一个这里，其他三个都没转换为条形码，求解

大翔象

大翔象 发表于 2024-8-26 09:11
大佬我执行了一下，有部分条形码都堆在了第一个这里，其他三个都没转换为条形码，求解

这个是我模板的问题，解决了