应坛友水若善的需求，给大家一段VBA程序，正确匹配环境和事件
前面章节我发布了《给大家演示<VBA制作工资条>》帖子，现在公布源代码（主体程序，代码完整，按顺序），有兴趣的童鞋自己组装下，看看是在哪里输入的（Sheet1还是Thisworkbook，是哪个事件触发的）：
程序代码1：
On Error Resume Next '当程序出错时候，继续执行下一句
'ActiveSheet.UsedRange.Select '全选有效数据
Range("A1").CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).Weight = xlThin
Dim a As Range, b%, c%, rowcount As Integer, rowblank As Integer, I, J, K As Integer
Set a = Application.InputBox("请选择相关区域（工资条表头）", "选取提示", , , , , , 8)
b = a.Rows.Count '判断获取的工资条的标题的行数
rowblank = Application.InputBox("请输入需要插入的行数（空行>=0）", "提示", , , , , , 1)
rowcount = Application.CountA(Sheet1.Range("a:a")) - 1
Sheet1.Cells(2 + b, 1).Select '判断需要插入行数后定位
If rowblank < 0 Then '当插入的空行小于0
MsgBox "请输入至少为0的空行"
End If
If rowblank = 0 Then '当插入的空行等于0，即从0开始
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = 1 To rowcount - 1
K = 2 + b + (rowblank + 1) * (I - 1)
For J = 1 To rowblank
Rows(K).Select
Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Next J
Next I
Sheet1.[A1].Select
For c = 1 To rowcount - 1 '开始复制标题
ActiveCell.Rows(1 & ":" & b).EntireRow.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Selection.Copy
ActiveCell.Offset(1 + b + rowblank, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Range("A1:A" & b).Select
Next c
End If
If rowblank > 0 Then '当插入的空行大于0，即从1开始
Application.ScreenUpdating = False
For I = 1 To rowcount - 1
K = 2 + b + (rowblank + 1) * (I - 1)
For J = 1 To rowblank
Rows(K).Select
Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Next J
ActiveCell.Rows(1 & ":" & rowblank).EntireRow.Select
ActiveCell.Rows(1 & ":" & rowblank).EntireRow.RowHeight = 7 '设置间隔行的行高为7
Selection.Borders(xlEdgeLeft).LineStyle = xlNone '去除边框
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Offset(1 + rowblank + b, 0).Range("A1").Select
Next I
Sheet1.[A1].Select
For c = 1 To rowcount - 1 '开始复制标题
ActiveCell.Rows(1 & ":" & b).EntireRow.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Selection.Copy
ActiveCell.Offset(1 + b + rowblank, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Range("A1:A" & b).Select
Next c
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = True
程序代码2：
Application.DisplayAlerts = False '关闭Excel的提示框
ThisWorkbook.Close savechanges:=True '保存文档
Application.CutCopyMode = False '关闭剪贴板提示
程序代码3：
Sheet1.Cells.Clear
Sheet1.Cells.RowHeight = 14.25
Sheet1.[A1].Select
以上每个代码程序都是一个独立完整的代码，对应的环境是不同的。看看谁最快组装好。
附件
-
VBA制作工资条.gif
(1.75 MB)
-
2015-9-8 10:05
