Excle也能编程-VBA小工具

工作中有用到，就学习了一下VBA编程。发现这个真的可以使得Excle工作效率倍增。
工作需求，为照片粘贴档案条。需要将一条条数据，转换为小纸片并且按照特殊样式排序。
完成后像这样

其实要完成这个还是比较简单的。
主要说说自己遇到的几个“坑”
1.此次样式用到了“模板”，并不是完全靠代码来调整出来的。
2.想用插件-窗口来封装“转换”操作。但是发现窗口不行，所以后面用到窗体中的按钮来实现。
3.因为要符合打印纸的格式，所以样式调了好一会儿。

首先建立标签的模板

像这样，在最右边建立相应的模板样式。

接下来就是编辑窗体代码了！
窗体代码

Dim a As Integer '声明一个公共变量
Private Sub UserForm_Initialize()
With Me
StartUpPosition = 0
Left = 600
Top = 50
End With
End Sub

Private Sub CommandButton1_Click()
    Call 生成档案条
    UserForm1.Hide
End Sub
Sub 生成档案条()
    Sheets(2).Activate
    Sheets(2).PageSetup.PrintArea = ""
    Dim MaxRow As Long '声明变量
    a = 0
    Application.ScreenUpdating = False
    MaxRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Cells(1, Columns.Count - 2).Resize(4, 3).Copy
    '将档案条模板粘贴到A列，且粘贴的份数由工资表的行数决定
    Range("a1:C" & (MaxRow - 1) * 4).PasteSpecial xlPasteAll
    Range("a1:C" & (MaxRow - 1) * 4).PasteSpecial xlPasteColumnWidths
    Range("a1:C" & (MaxRow - 1) * 4).PasteSpecial xlPasteFormulas
    Dim rowHigh As Range
    Dim rowHighBase As Range
    Dim HighBase As Integer
    For i = 1 To MaxRow * 4
        HighBase = i Mod 4
        If HighBase = 0 Then
            HighBase = 4
        Else
            HighBase = i Mod 4
        End If
        Set rowHigh = Rows(i)
        Set rowHighBase = Rows(HighBase)
        rowHigh.RowHeight = rowHighBase.RowHeight
    Next
    For i = 2 To MaxRow '循环复制数据
        复制数据 (i) '调用“复制数据”过程，将工资表的信息复制到工资卡中
    Next
Call 排版 '调用过程'排版'
    Application.ScreenUpdating = True
End Sub
Sub 复制数据(i As Integer)
'将‘档案的数据’填入每一份档案卡中
    Dim id As String
    id = Sheets(1).Cells(i, 2) & "." & Format(i - 1, "0000")
    Cells(4 * a + 1, 2) = id
    Cells(4 * a + 2, 2) = Sheets(1).Cells(i, 5)
    Cells(4 * a + 3, 2) = Sheets(1).Cells(i, 16)
    a = a + 1
End Sub
Private Sub 排版()
    lrow = 1
    drow = 0
    Application.ScreenUpdating = False
    Dim MaxRow As Long, c As Long
    MaxRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row '记录已用区域的行数
    c = Int(MaxRow / 2 + 1) '计算拆分成两列后纵向需要排列多少份
    For i = 1 To c '横向复制7次
        Range(Cells(c * (i) * 4 + 1, 1), Cells(Int(MaxRow / 2 + 1) * (i + 1) * 4, 3)).Copy
        '粘贴到右边一列
        Cells(1, i * 3 + 1).PasteSpecial xlPasteAll
        Selection.PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
    Next
    Rows((c * 3 + 1) & ":" & Rows.Count).Clear
    
    'Dim rng As Range
    'Set rng = Rows(1) '将第一行赋予变量
    'For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row + 1 Step 4
    '遍历所有行，步长为4
    '    Set rng = Union(rng, Rows(i)) ' 将Rng与第一行合并,即获得所有工资卡中的间隔行
    'Next
    'rng.RowHeight = 40
    '将 A 列到 F列的已用区域为打印区域
    Sheets(2).PageSetup.PrintArea = "$A$1:$F$" & Cells(Rows.Count, "A").End(xlUp).Row
    '页边距设置为0
    With Sheets(2).PageSetup
         .LeftMargin = Application.InchesToPoints(0) '左边距
        .RightMargin = Application.InchesToPoints(0)  '右边距
        .TopMargin = Application.InchesToPoints(0) '上边距
        .BottomMargin = Application.InchesToPoints(0) '下边距
        .HeaderMargin = Application.InchesToPoints(0) '页眉
        .FooterMargin = Application.InchesToPoints(0) '页脚
        .Orientation = xlPortrait '设置纵向打印模式
    End With
    ActiveWindow.View = xlPageBreakPreview ' 进入分页浏览状态
    '删除每页最上面多出来的一行
    Do While drow < MaxRow * 3 \ 2
        drow = lrow * 28
        Rows(drow).RowHeight = 20
        lrow = lrow + 1
    Loop
    'ActiveSheet.PageSetup.Orientation = xlLandscape '将页面设置为横向
    'ActiveWindow.View = xlPageBreakPreview ' 进入分页浏览状态
    'If ActiveSheet.VPageBreaks.Count > 0 Then '如果有纵向分页符'
        '将第一个分页符向右拖出'
    '    ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    'End If
    Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

Private Sub UserForm_Click()

End Sub

VBA虽然承袭了VB的代码，感觉有点儿坑。但是能让excle能够编程，并表现的更加自动化，真是比国产WPS强太多！