Sub 生成工资条() Dim wsSource As Worksheet, wsTarget As Worksheet Dim i As Long, j As Long, lastRow As Long, lastCol As Long Dim targetRow As Long '设置工作表 Set wsSource = ThisWorkbook.Worksheets("Sheet1") '源数据表名 On Error Resume Next Set wsTarget = ThisWorkbook.Worksheets("工资条") If wsTarget Is Nothing Then Set wsTarget = ThisWorkbook.Worksheets.Add(After:=wsSource) wsTarget.Name = "工资条" Else wsTarget.Cells.Clear End If On Error GoTo 0 '获取源数据范围 lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column targetRow = 1 '循环每个员工 For i = 2 To lastRow '1. 复制标题行 wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol)).Copy _ wsTarget.Cells(targetRow, 1) '2. 复制当前员工数据行 wsSource.Range(wsSource.Cells(i, 1), wsSource.Cells(i, lastCol)).Copy _ wsTarget.Cells(targetRow + 1, 1) targetRow = targetRow + 3 '标题行占1行，数据行占1行，空行占1行 Next i '可选：为标题行添加底色 For j = 1 To targetRow Step 3 wsTarget.Rows(j).Interior.Color = RGB(240, 240, 240) '浅灰色 Next j wsTarget.Columns.AutoFit wsTarget.Activate MsgBox "工资条生成完成！共生成 " & (lastRow - 1) & " 位员工的工资条。", vbInformation End Sub
