资产明细

生成标签效果

要制作700多个这样固定资产卡片，如果纯手工制作，没有2天真的搞不定，即便是搞定了还很容易出错。

现在好了，直接一键生成。5秒钟就直接搞定2天的工作量，爽吗？

写代码不容易，以后遇到一个好心帮你写代码的人，请大方赏个大红包，这不是开玩笑，这是认真的。

使用代码：

Sub 资产卡片()

Rem 定义几个必要的变量，最大行数，最大列数，指定表及区域

Dim Rm_lng As Long, Cm_int As Integer, Sh As Worksheet, Kap_Rng As Range

Rem 卡片跳跃数，循环变量，将隔行数，卡片数组

Dim Rs_By As Byte, i As Long, ii As Byte, RowC As Long, Arr()

Dim New_Sh As Worksheet

Set Sh = Worksheets("资产明细")

With Sh

Set Kap_Rng = Application.Intersect(.Range("a1").CurrentRegion, .UsedRange)

With Kap_Rng

Rm_lng = .Rows.Count

Cm_int = .Columns.Count

End With

End With

Set New_Sh = Worksheets.Add

With New_Sh

.Columns(1).ColumnWidth = 13

.Columns(2).ColumnWidth = 23

.Columns(3).ColumnWidth = 8

.Columns(4).ColumnWidth = 13

.Columns(5).ColumnWidth = 23

.Columns(6).ColumnWidth = 8

End With

Application.ScreenUpdating = False

Rs_By = 2 '每页2个卡片页面，3改3

ReDim Arr(1 To 6, 1 To 2)

Arr(1, 1) = "交通运输综合行政执法支队资产卡片"

Arr(2, 1) = "资产编号"

Arr(3, 1) = "资产名称"

Arr(4, 1) = "使用部门"

Arr(5, 1) = "使用人"

Arr(6, 1) = "存放地点"

For i = 2 To Rm_lng Step Rs_By

RowC = RowC + IIf(i = 2, 1, 7)

For ii = 1 To Rs_By

Arr(2, 2) = Kap_Rng(i + ii - 1, "A").Text

Arr(3, 2) = Kap_Rng(i + ii - 1, "B")

Arr(4, 2) = Kap_Rng(i + ii - 1, "G")

Arr(5, 2) = Kap_Rng(i + ii - 1, "H")

Arr(6, 2) = "'" & Kap_Rng(i + ii - 1, "Y").Text

With New_Sh

With .Cells(RowC, ii + IIf(ii = 1, 0, 2))

.RowHeight = 30

.Resize(6, 2) = Arr

.Resize(1, 2).Merge

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.CurrentRegion.Borders.LineStyle = 1

.Offset(1, 0).Resize(5, 1).RowHeight = 20

.Offset(1, 0).Resize(5, 1).HorizontalAlignment = xlCenter

.Offset(1, 0).Resize(5, 1).VerticalAlignment = xlCenter

.Offset(1, 1).Resize(5, 1).HorizontalAlignment = xlLeft

.Offset(1, 1).Resize(5, 1).VerticalAlignment = xlCenter

.Offset(6, 0).RowHeight = 13

End With

End With

If i = Rm_lng And i - 1 Mod 2 <> 0 Then Exit For

Next ii

Next i

Application.ScreenUpdating = True

End Sub

来源：Excel不加班，作者：卢子1987