按模板生成标签打印

djp1018 · 发表于 2025-11-11 17:05

sungtinedue 发表于 2025-11-11 16:11
删掉模板和打印2表中的D列
Sub ykcbf()
Application.ScreenUpdating = False

I列也要删除才行

绿色心情小天使 · 发表于 2025-11-11 22:42

ykcbf1100 发表于 2025-11-11 07:37
写了一个按模板生成打印表的代码，仅供参考。

代码仅适用于当前附件

EH的精英坛友：

   生成标签打印：
   现需增加一个条件：横排生成N张标签，有时需要3张或5张等
         如选5张，一排上显示5张
   再增加一个清空按钮：
         把生成的物料信息清空！
   现重新上传附件！
   麻烦大神的热忱大力相助，非常感谢！！！

生成标签打印1110.zip (30.06 KB, 下载次数: 12)
增加横列标签数1111.png

。

赵桢0611 · 发表于 2025-11-12 08:31

试试横排生成N张标签，目前设置最大10个

massCS · 发表于 2025-11-12 14:12

本帖最后由 massCS 于 2025-11-14 20:34 编辑

Option Explicit
Private Type rngConfig
rngAdd As String ' 地址
mRows As Variant ' 需要合并的行(集合)
dateAdd As String ' 日期格式单元格
colsWidth As Variant ' 列宽(集合)
rowsHeight As Variant ' 行高(集合)
borderAdd As String ' 设置框线区域
borderLineStyle As XlLineStyle ' 框线类型
borderWeight As XlBorderWeight ' 框线粗细
fontName As String ' 字体类型
fontSize As Double ' 字体大小
copyrCount As Long ' 横向数量
HPageRows As Long ' 纵向分页符添加行数
End Type
Private Const wsName0 As String = "Date"
Private Const wsName1 As String = "打印"
Private msgArr As Variant
Sub Main()
Dim RC As rngConfig, arr As Variant
SetApps False
msgArr = Array("完成 !", "源数据为空", "请输入横向数量", "横向数量不合法")
If InputData(arr, RC) Then
OutputData arr, RC
MsgBox msgArr(0)
End If
SetApps True
End Sub
Private Function InputData(dataArr As Variant, RC As rngConfig) As Boolean
Dim ir As Long, i As Long, temp
InputData = False
' 获取数据源
With ThisWorkbook.Sheets(wsName0)
LastRow .Range("A:G"), ir
If ir < 2 Then MsgBox msgArr(1): Exit Function
dataArr = .Range("A2:G" & ir).Value
End With
' 获取横向间隔
temp = Val(InputBox(msgArr(2), , 3))
temp = Int(temp)
If temp <= 0 Then MsgBox msgArr(3): Exit Function
If temp < 3 Then temp = 3
If temp > 5 Then temp = 5
' 配置参数
With RC
.rngAdd = "A1:D8"
.mRows = Array(1, 2, 3, 4, 6, 7)
.dateAdd = "B6"
.colsWidth = Array(8.91, 19.82, 7.36, 1.36)
.rowsHeight = Array(18.5, 10)
.borderAdd = "A1:C7"
.borderLineStyle = xlContinuous
.borderWeight = xlThin
.fontName = "宋体"
.fontSize = 11
.copyrCount = temp
.HPageRows = IIf(temp = 3, 8, IIf(temp = 4, 10, 12))
End With
InputData = True
End Function
Private Sub OutputData(dataArr As Variant, RC As rngConfig)
Dim rng As Range
Dim maxrow As Long, maxcol As Long, rowsCount As Long, colsCount As Long
Dim i As Long, j As Long, r As Long, c As Long
With ThisWorkbook.Sheets(wsName1)
.Rows.Delete Shift:=xlUp
Set rng = .Range(RC.rngAdd)
End With
' 设置区域格式,获取必要参数
With rng
maxrow = .Rows.Count: maxcol = .Columns.Count ' 最大行列数
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormatLocal = "@"
.Range(RC.dateAdd).NumberFormatLocal = "yyyy/m/d"
.Columns(1).ColumnWidth = RC.colsWidth(0)
.Columns(2).ColumnWidth = RC.colsWidth(1)
.Columns(3).ColumnWidth = RC.colsWidth(2)
.Columns(4).ColumnWidth = RC.colsWidth(3)
.Rows("1:7").RowHeight = RC.rowsHeight(0)
.Rows(8).RowHeight = RC.rowsHeight(1)
.Range(RC.borderAdd).Borders.LineStyle = RC.borderLineStyle
.Range(RC.borderAdd).Borders.Weight = RC.borderWeight
.Font.Name = RC.fontName
.Font.Size = RC.fontSize
For i = 0 To UBound(RC.mRows)
.Range("B" & RC.mRows(i)).Resize(1, 2).Merge
Next i
.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("LOGO", "品号", "品名", "规格", "数量", "入库时间", "项目") _
)
.Range("B1").Value = "物料标识卡"
End With
' 获取打印范围
j = WorksheetFunction.RoundUp(UBound(dataArr, 1) / RC.copyrCount, 0)
rowsCount = j * maxrow - 1 ' 去掉最后一行自带分隔行
colsCount = RC.copyrCount * maxcol - 1 ' 去掉最后一列自带分隔列
With ThisWorkbook.Sheets(wsName1)
' 横向复制
c = 1
For i = 1 To RC.copyrCount - 1
rng.EntireColumn.Copy .Cells(1, c + maxcol)
c = c + maxcol
Application.CutCopyMode = False
Next i
' 纵向复制
r = 1: c = 1
For i = 1 To j - 1
rng.EntireRow.Copy .Cells(r + maxrow, 1)
r = r + maxrow
c = c + 1
If c = RC.HPageRows Then
.HPageBreaks.Add Before:=.Cells(r, 1): c = 1 ' 添加水平分页符
End If
Application.CutCopyMode = False
Next i
' 写值
j = 1: r = 1: c = 1
For i = 1 To UBound(dataArr, 1)
With .Cells(r, c).Resize(maxrow, maxcol)
.Cells(2, 2).Value = dataArr(i, 1)
.Cells(3, 2).Value = dataArr(i, 2)
.Cells(4, 2).Value = dataArr(i, 3)
.Cells(5, 2).Value = dataArr(i, 5)
.Cells(5, 3).Value = dataArr(i, 4)
.Cells(6, 2).Value = dataArr(i, 6)
.Cells(7, 2).Value = dataArr(i, 7)
End With
If j = RC.copyrCount Then
j = 1
r = r + maxrow
c = 1
Else
j = j + 1
c = c + maxcol
End If
Next i
End With
SetPagePrint rowsCount, colsCount ' 调整打印
Set rng = Nothing
End Sub
Private Sub SetPagePrint(rowsCount As Long, colsCount As Long)
On Error Resume Next
Dim pAdd As String
Dim LR As Double
Dim tbNum As Double
Dim hfNum As Double
With ThisWorkbook.Sheets(wsName1)
pAdd = .Range(.Cells(1, 1), .Cells(rowsCount, colsCount)).Address
lrNum = Application.CentimetersToPoints(0.8)
tbNum = Application.CentimetersToPoints(0.5)
hfNum = Application.CentimetersToPoints(0.5)
With .PageSetup
.PrintArea = pAdd
.CenterHorizontally = True ' 内容水平居中
' .CenterVertically = True ' 内容垂直居中
.PaperSize = xlPaperA4 ' A4纸张
.Zoom = False ' 禁用缩放
.FitToPagesWide = 1: .FitToPagesTall = False ' 强制1页宽,高度自适应(不限定页数)
.LeftMargin = lrNum: .RightMargin = lrNum ' 左右页边距：0.8厘米
.TopMargin = tbNum: .BottomMargin = tbNum ' 上下页边距：0.5厘米
.HeaderMargin = hfNum: .FooterMargin = hfNum ' 页眉页脚边距：0.5厘米
End With
End With
On Error GoTo 0
End Sub
Private Sub SetApps(Isopen As Boolean)
With Application
.DisplayAlerts = Isopen: .ScreenUpdating = Isopen
.Calculation = IIf(Isopen, xlAutomatic, xlManual)
End With
End Sub
Private Sub LastRow(rng As Range, retnum As Long)
Dim rng1 As Range
If rng.Worksheet.FilterMode Then rng.Worksheet.ShowAllData
Set rng1 = rng.Find("*", LookIn:=xlValues, _
searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If rng1 Is Nothing Then retnum = 0 Else retnum = rng1.Row
Set rng1 = Nothing
End Sub

复制代码

模板可有可无

Enocheasty · 发表于 2025-11-12 17:40

自荐一下我的插件，免费的，适合Office2013+
自编的插件Excel助手更新V1.3-VSTO-ExcelHome技术论坛 -

可以制作各种这种类型的批量复制，模板自己调整好，包括字体，样式等等。
第一步，给模板设定数据参数：
批量制作1.gif

第二步，选择数据，设定布局，输出
批量制作2.gif

绿色心情小天使 · 发表于 2025-11-12 23:17

Enocheasty 发表于 2025-11-12 17:40
自荐一下我的插件，免费的，适合Office2013+
自编的插件Excel助手更新V1.3-VSTO-ExcelHome技术论坛 -

看着很不错，很好！就是这个软件下载不了。

绿色心情小天使 · 发表于 2025-11-13 13:08

massCS 发表于 2025-11-12 14:12
模板可有可无

经测试，有好多清空.....
清空.png

massCS · 发表于 2025-11-13 16:36

绿色心情小天使发表于 2025-11-13 13:08
经测试，有好多清空.....

源文件是没有这些控件的,这个也不需要清空内容,每次都是重新生成

massCS · 发表于 2025-11-13 16:40

massCS 发表于 2025-11-13 16:36
源文件是没有这些控件的,这个也不需要清空内容,每次都是重新生成

已上传附件

绿色心情小天使 · 发表于 2025-11-13 20:34

massCS 发表于 2025-11-12 14:12
模板可有可无

晚上好：
感谢大力相助！

还有一个问题，打印第2页和第三页时，没有显示全部，上半空了一大截，如下图。

		自动登录	找回密码
密码			免费注册

[求助] 按模板生成标签打印

评分

评分

评分