如何将工资表以员工的名字另存为一个个单独的文件
工资表已经做成工资条的形式，现在就差最后一步，就是以员工的姓名为文件名另存为一个个单独的文件。这些文件保存在 同一目录＼文件夹下。谢谢各位大神帮忙，小弟感激不尽！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
有那位高人可以将这段代码整合我的文件，更改为导出的是一个个单独的图片，而不是文件，谢谢，谢谢，万分感谢！
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
页:
[1]