自动导出工资条

jaxpqh

　　我有一个《工资明细表》，里面有全年全体员工的工资明细，想要按月导出《工资条》，请哪位大师帮助一下，先谢谢了！

　　一、新建一个工作簿存放ＶＢＡ代码，运行代码时不打开《工资明细表》；

　　二、运行代码时，手动输入要导出的年月，默认为当月；

　　三、导出的《工资条》存在一个命名为《工资条》的文件夹里；

　　四、导出的《工资条》的工作簿名和工作表名均命名为“****年*月工资条”；

　　五、每一个工资条之间空一行，并用虚边框线间隔开来，方便裁剪。

A刘志勇

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, n&, iYearMonth&, strPath$, a
    Dim wks As Worksheet, iPosRow&, strName$
   
    iYearMonth = Application.InputBox("请选择年月，形式202405", Title:="提示", Default:=Format(Now(), "yyyymm"), Type:=1)
    If iYearMonth = 0 Then Exit Sub
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    With [A1].CurrentRegion
        ar = .Value
        br = .Rows(1)
        ReDim cr(1 To 3, 1 To UBound(ar, 2) - 1)
    End With
   
    strPath = ThisWorkbook.Path & "\工资条\"
    With Workbooks.Add
        strName = Left(iYearMonth, 4) & "年" & Right(iYearMonth, 2) & "月工资条"
        With .Worksheets(1)
            .Name = strName
            For i = 2 To UBound(ar)
                If Format(ar(i, 1), "yyyymm") = iYearMonth Then
                     cr(1, 1) = strName
                     For j = 1 To UBound(cr, 2)
                         cr(2, j) = br(1, j + 1)
                         cr(3, j) = ar(i, j + 1)
                     Next j
                     n = n + 1
                     iPosRow = (n - 1) * 4 + 2
                     With .Cells(iPosRow, 1).Resize(3, UBound(cr, 2))
                         .Value = cr
                         .HorizontalAlignment = xlCenter
                         With .Rows(1)
                             If n > 1 Then .Borders(xlEdgeTop).Weight = xlHairline
                             .Merge
                             .Font.Bold = True
                             .Font.Name = "Times New Roman"
                             .Font.Size = 26
                         End With
                         With .Rows(2)
                             .Font.Name = "宋体"
                             .Font.Bold = True
                             .Font.Size = 12
                         End With
                         With .Rows(3)
                             .Font.Name = "Times New Roman"
                             .Font.Size = 12
                         End With
                         With Intersect(.Offset(), .Offset(1))
                             .Borders.LineStyle = xlContinuous
                         End With
                     End With
                End If
            Next i
        End With
        .SaveAs strPath & strName
        .Close
    End With
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

hilylwz

https://club.excelhome.net/thread-1687203-1-1.html

分享一个我自己编的工资条制作工具，用着还不错，工资条生成后方便裁剪和发放。可以制作个人单月工资条和汇总工资总表，可以试试。

wcj6376tcp

用我自己在用的给你修改了一下

明天会更好zj

都信息时代了，还在用工资条呀？

prome3

明天会更好zj 发表于 2024-3-17 11:31
都信息时代了，还在用工资条呀？

我刚想说这是落后的标志，后来想想，这不只是落后的标志，

它就是落后的，生产经营管理方式。

（不是看起来落后，而是就是落后）

【论坛上有很多搞人力资源或者财务的，用VBA来处理考勤、工资结算一类事务，群发邮件什么的；但像此帖用来做工资条，实在是……看起来像是一种退步的做法】