如何将工资表以员工的名字另存为一个个单独的文件

快还钱

工资表已经做成工资条的形式，现在就差最后一步，就是以员工的姓名为文件名另存为一个个单独的文件。这些文件保存在 同一目录＼文件夹下。谢谢各位大神帮忙，小弟感激不尽！

Sub SaveRangeAsPic()
  Dim strPath As String
  Dim Rng As Range
  strPath = ThisWorkbook.Path
  Set Rng = Range("A1:C8")
  Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  ActiveSheet.Paste
  With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
  Selection.Delete
  .Parent.Select
  .Paste
  .Export strPath & "\" & Format(Now(), "yyyymmddhhmmss") & ".jpg", "JPG"
  .Parent.Delete
  End With
End Sub
有那位高人可以将这段代码整合我的文件，更改为导出的是一个个单独的图片，而不是文件，谢谢，谢谢，万分感谢！
工资表.rar (46.85 KB, 下载次数: 12)

2021-10-26 18:17 上传

点击文件名下载附件
工资表.rar

刘宸

Private Sub S() '书生答题专用
  Call 加速(False)
  Dim i, j, k, arr, brr, x, y
  h = Cells(Rows.Count, 1).End(xlUp).Row
  m = ThisWorkbook.Name
  For i = 1 To h Step 6
  a = Cells(i + 5, 2) & ".xlsx"
  Workbooks.Add
  ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & a
  Workbooks(m).Activate
  Range(Cells(i + 1, 1), Cells(i + 5, 27)).Copy
  Workbooks(a).Activate
  Range("A2").Select
  ActiveSheet.Paste
  Range("A1") = "工资表"
  Range("A1:a9").RowHeight = 22
  Range("A1:z1").Merge
  Range("A1:z1").HorizontalAlignment = xlCenter
  ActiveWorkbook.Close True
  Next
  Call 加速(True)
End Sub
Public Function 加速(开关 As Boolean)
  If 开关 Then
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  Else
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  End If
End Function

云水禅意

谢谢，我运行了你的代码，但只能生成一个文件，而且要点回车键才会生成？是我操作有问题吗？而且生成的文件跟工资表不在同一个文件夹里？

晴聆

Dim wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To Cells(Rows.Count, 1).End(3).Row Step 6
  Set wb = Workbooks.Add
  With wb
  Cells(1, 1).Resize(1, 26).Copy
  wb.Sheets(1).Range("a1").PasteSpecial
  Cells(i, 1).Resize(6, 26).Copy
  wb.Sheets(1).Range("a2").PasteSpecial
  
  wb.SaveAs ThisWorkbook.Path & "\" & Cells(i + 4, 2).Value & ".xlsx"
  wb.Close True
  End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True

夜光杯下的葡萄酒

默认放在一个文件夹中，我这里测试，没问题

夏日清茶

Sub s()
  Dim wb As Workbook
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  m = ThisWorkbook.Name
  For i = 2 To Cells(Rows.Count, 1).End(3).Row Step 6
  Set wb = Workbooks.Add
  With wb
    Workbooks(m).Activate
    Cells(1, 1).Resize(1, 26).Copy
    wb.Sheets(1).Range("a1").PasteSpecial
    Cells(i, 1).Resize(6, 26).Copy
    wb.Sheets(1).Range("a2").PasteSpecial
    wb.SaveAs ThisWorkbook.Path & "" & Cells(i + 4, 2).Value & ".xlsx"
    wb.Close True
  End With
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

可可爹滴

更高一级要求，能否将每人的工资条导出为图片而不是EXCEL文件
我在论坛看到有这段代码，但是不会整合，谢谢！
Sub SaveRangeAsPic()
  Dim strPath As String
  Dim Rng As Range
  strPath = ThisWorkbook.Path
  Set Rng = Range("A1:C8")
  Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  ActiveSheet.Paste
  With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
  Selection.Delete
  .Parent.Select
  .Paste
  .Export strPath & "\" & Format(Now(), "yyyymmddhhmmss") & ".jpg", "JPG"
  .Parent.Delete
  End With
End Sub