【Excel VBA】2018-10-08 制作工资条

案例

案例来源：Excel和Access （微信公众号）点击 - 查看原文

根据源数据，制作带空行或者不带空行的工资条。

附件：点击查看-百度云
提取密码：uvvo

一、数据源代码

Sub 源数据代码()
    '录入数据
    Cells(1, 1) = "员工号"
    Cells(1, 2) = "姓名"
    Cells(1, 3) = "部门"
    Cells(1, 4) = "工资"
    Cells(1, 5) = "奖金"
    Cells(1, 6) = "应发工资"
    
    Cells(2, 1) = "A12"
    Cells(2, 2) = "甲"
    Cells(2, 3) = "技术部"
    Cells(2, 4) = "3600"
    Cells(2, 5) = "700"
    Cells(2, 6) = "4300"
    
    Cells(3, 1) = "A13"
    Cells(3, 2) = "乙"
    Cells(3, 3) = "开发部"
    Cells(3, 4) = "3100"
    Cells(3, 5) = "800"
    Cells(3, 6) = "3900"
    
    Cells(4, 1) = "A14"
    Cells(4, 2) = "丙"
    Cells(4, 3) = "发展部"
    Cells(4, 4) = "2900"
    Cells(4, 5) = "900"
    Cells(4, 6) = "3800"
    
    Cells(5, 1) = "A15"
    Cells(5, 2) = "丁"
    Cells(5, 3) = "销售部"
    Cells(5, 4) = "2200"
    Cells(5, 5) = "400"
    Cells(5, 6) = "2600"

    Cells(6, 1) = "A16"
    Cells(6, 2) = "戊"
    Cells(6, 3) = "综合部"
    Cells(6, 4) = "2900"
    Cells(6, 5) = "500"
    Cells(6, 6) = "3400"
    
    '格式调整
    With Range("a1:f6")
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
    End With
    With Range("a1:f1")
        .Font.Bold = True
        .Interior.ColorIndex = 15
    End With
    ActiveWindow.DisplayGridlines = False '设置网格线
End Sub

.Interior.Colorindex = 15 , 表示设置单元格的背景颜色-灰色

二、制作不带空行的工资条

Sub 示例制作不带空行工资条()
Dim I, K, M As Integer

K = InputBox("请输入工资条起始行号，该行号要大于已有工资表数据的行号!", "提示")

If K < Range("a1").End(xlDown).Row Then
    MsgBox "您输入的起始行号过少，将会造成错误，请重新输入！", vbCritical, "警告"
Exit Sub
End If

For I = 2 To Range("a1").End(xlDown).Row
    Range("a1:f1").Copy Destination:=Range("a" & K + 2 * M)
    Range("a" & I & ":f" & I).Copy Destination:=Range("a" & K + 1 + 2 * M)
    M = M + 1
Next
'利用m循环增加工资条位置，2*M表示每次循环，工资条向下位移2个位置；3*M表示每次循环，工资条向下位移3个位置，带空行
End Sub

2.1 For循环，利用源数据工资表的最后一行行号
2.2 利用M，做每次工资条位置的变化

三、制作带空行的工资条

Sub 示例制作带空行工资条()
Dim I, K, M As Integer

K = InputBox("请输入工资条起始行号，该行号要大于已有工资表数据的行号!", "提示")

If K < Range("a1").End(xlDown).Row Then
    MsgBox "您输入的起始行号过少，将会造成错误，请重新输入！", vbCritical, "警告"
Exit Sub
End If

For I = 2 To Range("a1").End(xlDown).Row
    Range("a1:f1").Copy Destination:=Range("a" & K + 3 * M)
    Range("a" & I & ":f" & I).Copy Destination:=Range("a" & K + 1 + 3 * M)
    M = M + 1
Next
End Sub

• 与不带空行的区别，是在调用m的时候，通过每次增加3行变量，其中带值2行，空1行。

自制工资条代码

Sub 自制工资条()
Dim BiaoTi As Ranges
Dim d As Long
Dim I, x As Integer

'自适应获取excel行数
Range("a1").EntireColumn.Insert shift:=xlShiftToRight
d = Range("a:a").End(xlDown).Row
Range("a1").EntireColumn.Delete shift:=xlShiftToLeft

x = Range("a" & d).End(xlUp).Row

For I = 2 To x
    Range("1:1").Copy Range("a" & Range("a" & d).End(xlUp).Row + 2)
    Rows(I).Copy Range("a" & Range("a" & d).End(xlUp).Row + 1)
Next


End Sub

自制工资条，通过插入新列-统计表格行数-删除新列，得到一个固定的A列最底的单元格。
工资条是否空行，在第一个复制的地方，.Row+1不空行；.Row+2空行。