|
|
Sub 批量生成标签()
Application.ScreenUpdating = False
Dim ar As Variant
Dim rn As Range
With Sheets("标签明细")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "标签明细为空！": End
ar = .Range("a1:g" & r)
End With
Set rn = Sheets("模板").Rows("1:7")
With Sheets("标签")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
For Each shp In .Shapes
shp.Delete
Next shp
.Rows("1:" & rs).Delete
For i = 2 To UBound(ar)
If ar(i, 1) <> "" And ar(i, 7) <> "" Then
If IsNumeric(ar(i, 7)) Then
sl = ar(i, 7)
If sl / 2 = Int(sl / 2) Then
gs = sl / 2
Else
gs = Int(sl / 2) + 1
End If
ws = .Cells(Rows.Count, 1).End(xlUp).Row + 1
If ws = 2 Then
ws = 1
Else
ws = ws
End If
m = ws
For s = 1 To gs
rn.Copy .Cells(m, 1)
m = m + 8
Next s
m = ws + 1
For s = 1 To sl Step 1
If s Mod 2 <> 0 Then
lh = 2
m = m
Else
lh = 7
m = m - 8
End If
.Cells(m, lh) = ar(i, 1)
.Cells(m + 1, lh) = ar(i, 2)
.Cells(m + 2, lh) = ar(i, 3)
.Cells(m + 3, lh) = ar(i, 4)
.Cells(m, lh + 2) = ar(i, 5)
.Cells(m, lh + 2) = ar(i, 5)
.Cells(m + 1, lh + 2) = ar(i, 6)
m = m + 8
Next s
End If
End If
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-10-28 18:44
楼主