如何修改批量生成工资条并批量截图保存为图片文件

feiyang007

需要对工资条进行批量生成，然后批量截图在文件夹中，按照一定的名字进行命名。目前只收集到一行表头，一行数据的这种两列形式的。这个不能满足我的需要。因为工资构成的原因，我需要3行的表头，这样要如何进行修改呢？求教大神们，谢谢。
工资条的构成如下：

liulang0808

楼主的附件中没有代码的。

feiyang007

Sub GeneratePaySlip()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Dim Fs, ReadSheet As Worksheet, Rng As Range, DateS As String, SavePath As String, FileS As String, RowsCount As Long, ColumnsCount As Long, K As Long, JD_All As Long, JD_Now As Long
    Set Fs = CreateObject("Scripting.FileSystemObject")
    If Fs.FolderExists(ThisWorkbook.Path & "\工资条") = False Then Fs.CreateFolder (ThisWorkbook.Path & "\工资条")
    DateS = ActiveSheet.Name
    ActiveSheet.Copy , Sheets(Sheets.Count)
    Set ReadSheet = Sheets(Sheets.Count)
    RowsCount = ReadSheet.UsedRange.Rows.Count
    If RowsCount > 1 Then
        ColumnsCount = ReadSheet.UsedRange.Columns.Count
        ReadSheet.Rows("1:" & RowsCount).RowHeight = 20
        ReadSheet.Rows("1:" & RowsCount).Font.Bold = True
        For K = RowsCount To 3 Step -1 '对第K行插入一行。
            ReadSheet.Cells(K, 1).Resize(1, 1).EntireRow.Insert
        Next
        RowsCount = ReadSheet.UsedRange.Rows.Count
        ReadSheet.Rows("1:1").Copy
        Set Rng = ReadSheet.Rows(3)
        For K = 3 To RowsCount Step 2
            Set Rng = Union(Rng, ReadSheet.Rows(K))
        Next
        Rng.Select
        ReadSheet.Paste
        SavePath = ThisWorkbook.Path & "\工资条\"
        JD_All = Int(RowsCount / 2)
        On Error GoTo ExitLine
        For K = 2 To RowsCount Step 2
            FileS = ReadSheet.Cells(K, 2) & "(" & DateS & ")工资条"
            ReadSheet.Range(ReadSheet.Cells(K - 1, 1), ReadSheet.Cells(K, ColumnsCount)).Copy
            ReadSheet.Pictures.Paste.Select
            With Selection
                .Copy
                    With ReadSheet.ChartObjects.Add(0, 0, .Width, .Height).Chart
                        .Paste
                        .Export FileName:=SavePath & FileS & ".jpg", FilterName:="jpg"
    '                    .Export FileName:=SavePath & FileS & ".png", FilterName:="png"
    '                    .Export FileName:=SavePath & FileS & ".bmp", FilterName:="bmp"
                        .Parent.Delete
                    End With
                .Delete
            End With

feiyang007

在帖子上附带了一段代码，如何修改呢？

feiyang007

求教大家，谢谢

sj15627581616

核心代码是如何导出剪切板图片保存到本地，论坛应该有现成的源码

sj15627581616

至于表头啥的，可以考虑筛选进行操作

考试加油站

找个AI提问即可生成，如豆包，文心上言