已解决老师帮忙修改代码

38180203

上面两条是生成工资条样式.有多少员工就本表最底下留个空白处生成多少工资条


人员姓名行高25   空白行高8

人员行数远远不止这么多.上面只是样式.

现在的代码是只能复制表头...信息是空白的...谢谢老师

半百

小凡、、、

另起一个表格存放会不会好一点

wengjl

办公电脑有加密，附件不发了
工资条做到另一张表上

练手！



Sub 生成资条()
    '
    ' https://club.excelhome.net/threa ... tml?_dsign=3e09058f
    ' 2024-6-12
    Sheet2.Select
    Columns("A:Y").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    '---
    Sheet1.Select
    x1 = 4
    Do While Not (IsEmpty(Sheet1.Cells(x1, 2).Value))
      x1 = x1 + 1
    Loop
    ygrs = x1 - 4
    Range(Cells(2, 1), Cells(3, 24)).Select
    Selection.Copy
    Sheet2.Select
    For i = 1 To ygrs * 4 Step 4
      Cells(i, 1).Select
      ActiveSheet.Paste
    Next i
    '---
    x1 = 4
    Do While Not (IsEmpty(Sheet1.Cells(x1, 2).Value))
      For y = 1 To 23
        Sheet2.Cells((x1 - 3) * 4 - 1, y).Value = Sheet1.Cells(x1, y).Value
      Next y
      Range(Cells((x1 - 3) * 4 - 1, 1), Cells((x1 - 3) * 4 - 1, 24)).Select
      添加表格线
      x1 = x1 + 1
    Loop
End Sub
Sub 添加表格线()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

313667354

参与下，在另一工作表生成。

38180203

小凡、、、 发表于 2024-6-12 13:36
另起一个表格存放会不会好一点

老师,怎么只能复制前面7个人员的工资条....后面的没有出来..谢谢

小凡、、、

38180203 发表于 2024-6-12 14:35
老师,怎么只能复制前面7个人员的工资条....后面的没有出来..谢谢

表头占了3行，for i = 4 to ..... +3,多循环三行

ykcbf1100

生成工资条

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.12   生成工资条
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("工资条")
   
5.     sh.UsedRange.Clear
   
6.     With Sheets("工资")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         Set bt = .Rows(2 & ":" & 3)
   
9.         For i = 4 To r
   
10.             m = m + 1
    
11.             If m = 1 Then
    
12.                 bt.Copy sh.[a2]
    
13.             Else
    
14.                 bt.Copy sh.Cells(r1 + 3, 1)
    
15.             End If
    
16.             sh.[y:y] = ""
    
17.             r1 = sh.Cells(Rows.Count, "g").End(3).Row
    
18.             .Rows(i).Copy sh.Cells(r1 + 1, 1)
    
19.             sh.Rows(r1 + 1 & ":" & r1 + 1).RowHeight = 25
    
20.             sh.Rows(r1 + 2 & ":" & r1 + 2).RowHeight = 8
    
21.         Next
    
22.     End With
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

38180203

小凡、、、 发表于 2024-6-12 14:37
表头占了3行，for i = 4 to ..... +3,多循环三行

老师,可不可以加句清除代码  现在是运行一次再点一次就累加  点一次就往后面累加