工资条制作

36K纯帅

各位老师，有个制作工资表需求，能否使用VBA实现呢
根据工资表自动生成工资条（数据有很多，表头需要自动生成，对应的公司名称和月份）

工资表：




工资条：

dragonthree

论坛一大把，搜索搜索搜索！

excel玉米

在论坛里搜索一下，有相同的案例可以学习

longwin

请看附件......

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, r&, dic As Object, Rng As Range, iPosRow&

    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    With Worksheets("工资表")
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        With .Range("A1:V" & r)
            ar = .Value
            Set Rng = .Rows("1:3")
            For i = 4 To UBound(ar)
                If Not dic.exists(ar(i, 2)) Then
                    Set dic(ar(i, 2)) = Rng
                End If
                Set dic(ar(i, 2)) = Union(dic(ar(i, 2)), .Rows(i))
            Next
        End With
    End With
    With Worksheets("工资条")
        .Cells.Delete
        For i = 0 To dic.Count - 1
            iPosRow = (i * 6) + 1
            dic.items()(i).Copy
            .Cells(iPosRow, 1).PasteSpecial Paste:=xlPasteColumnWidths
            dic.items()(i).Copy .Cells(iPosRow, 1)
        Next i
        .Activate
    End With
   
    Set dic = Nothing: Set Rng = Nothing
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

gwjkkkkk

。。。。。。。。。

ykcbf1100

生成工资条

参与一下。。。

ykcbf1100

生成工资条

1. Sub ykcbf() '//2024.7.10     生成工资条
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("工资条")
   
4.     Sheets("工资条").UsedRange.Clear
   
5.     With Sheets("工资表")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         For i = 4 To r
   
8.             m = m + 1
   
9.             r = (m - 1) * 6 + 1
   
10.             Sheets("模板").Rows(1 & ":" & 6).Copy sh.Cells(r, 1)
    
11.             .Cells(i, 1).Resize(, 22).Copy sh.Cells(r + 3, 1)
    
12.             sh.Cells(r + 3, 1) = m
    
13.         Next
    
14.     End With
    
15.     Application.ScreenUpdating = True
    
16.     MsgBox "OK！"
    
17. End Sub
    
18. 
    

复制代码

usedrange

有点慢，人数不多应该没问题的

1. Sub t()
   
2.     Dim gz, m%, i%, r%
   
3.     With Sheets("工资表")
   
4.         Set gz = .[a3].CurrentRegion
   
5.         r = 1
   
6.         For i = 4 To UBound(gz.Value2)
   
7.             .Range("a1:v3").Copy Sheet2.Range("y" & r).Resize(4, 22)
   
8.             .Cells(i, 1).Resize(1, 22).Copy Sheets("工资条").Range("y" & r + 3).Resize(1, 22)
   
9.             Set s = Sheets("工资条").Cells(r, "y")
   
10.             s.Replace What:="XX", Replacement:=gz(i, 23), LookAt:=xlPart
    
11.             r = r + 6
    
12.         Next i
    
13.         Sheets("工资条").Cells(r, "y").Resize(1000, 22).Rows.AutoFit
    
14.     End With
    
15. End Sub
    

复制代码

sunya_0529

WPS里的JSA练习一下——