[HELP] - Tách file payment theo form có password

Liên hệ QC

subasatran

Thành viên hoạt động
Tham gia
17/3/13
Bài viết
112
Được thích
6
Xin chào Anh/Chị/Em GPE
Do như cầu trong công việc mình muốn nhờ mọi người giúp đỡ.
Mình muốn in ra bảng chi tiết lương và gởi về mail cá nhân cho từng người.
Trong file mình gởi có 2 Sheet, một sheet data chứa thông tin chi tiết của nhân viên và một sheet form Payslip của bảng lương.
Giờ mình muốn tách ra form Payslip của từng người với yêu cầu như bên dưới :
+ Tên file, tên sheet sẽ là mã số của nhân viên.
+ File in ra có thể là excel hoặc pdf
+ Nếu tách xong mà có thể đặt luôn password thì thật tuyệt vời(password là mã số của nhân viên).
+ Vì các nhân viên giữ một chức vụ khác nhau nên có thể người này có khoản tiền này mà người kia không có nên khi in bảng lương, những khoản tiền bằng 0 thì sẽ ko được show ra trên payslip.
Mình có làm ví dụ tại file đính kèm cho mọi người dễ hình dung.
Mong mọi người tư vấn và giúp đỡ. Cám ơn rất nhiều.
 

File đính kèm

  • Ket qua sau khi tach.zip
    43 KB · Đọc: 24
  • Payslip_Template.zip
    20.9 KB · Đọc: 22
Mã:
Public Sub GPE()
Dim sArr, I As Long, Path As String
Path = ThisWorkbook.Path
sArr = Sheets("Data").Range("B8", Sheets("Data").Range("B8").End(4)).Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet1
.PageSetup.PrintArea = "$B$2:$D$32"
    For I = 1 To UBound(sArr)
        .Range("A2").Value = sArr(I, 1)
        .Range("B4:D32").AutoFilter 3, "<>0"
        .Range("B2:D32").SpecialCells(xlCellTypeVisible).Copy
        With Workbooks.Add
            .Sheets(1).Range("A1").PasteSpecial 8
            .Sheets(1).Range("A1").PasteSpecial xlPasteValues
            .Sheets(1).Range("A1").PasteSpecial xlPasteFormats
            .SaveAs Path & "\" & sArr(I, 1) & ".xlsx", 51, sArr(I, 1)
            .Close
        End With
    Next
    .AutoFilterMode = False
End With
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Rất cảm ơn sự giúp đỡ rất nhiệt tình của hpkhuong. Giải quyết rất gọn :). Không biết cảm ơn thế nào
 
Cho mình hỏi thêm một tí nữa.
Bây giờ nếu chỉ muốn tách ra sheet với các yêu cầu như bên trên thì code phải sửa lại như thế nào vậy ?
Cám ơn rất nhiều.

Đoạn code bên dưới sai ở chỗ nào mà khi chạy vẫn lọc được nhưng những sheet mới đã filter lại ko paste Value được. Thanks

Mã:
Public Sub GPE()
Dim sArr, I As Long, Path As String
Path = ThisWorkbook.Path
sArr = Sheets("Data").Range("B8", Sheets("Data").Range("B8").End(4)).Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = 1 To UBound(sArr)
                               With ActiveWorkbook.Worksheets("Form Payslip")
                              .PageSetup.PrintArea = "$B$2:$D$32"
                              .Range("A2").Value = sArr(I, 1)
                              .Range("B4:D32").AutoFilter 3, "<>0"
                              .Range("B2:D32").SpecialCells(xlCellTypeVisible).Copy
                              .Copy After:=Sheets(Sheets.Count)
                              End With
                              With ActiveSheet
                                   .Name = sArr(I, 1)
                              End With
         Next
       
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Lần chỉnh sửa cuối:
@hpkhuong : Bạn có thể giúp sửa lại code không tách theo file mà tách theo sheet thôi được ko ?
Cám ơn bạn.
 
@hpkhuong : Bạn có thể giúp sửa lại code không tách theo file mà tách theo sheet thôi được ko ?
Cám ơn bạn.
Mã:
Public Sub GPE()
Dim sArr, I As Long
sArr = Sheets("Data").Range("B8", Sheets("Data").Range("B8").End(4)).Value
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet1
.PageSetup.PrintArea = "$B$2:$D$32"
    For I = 1 To UBound(sArr)
        .Range("A2").Value = sArr(I, 1)
        .Range("B4:D32").AutoFilter 3, "<>0"
        .Range("B2:D32").SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        With Sheets(Sheets.Count)
            .Name = sArr(I, 1)
            .Range("A1").PasteSpecial 8
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
        End With
    Next
    .AutoFilterMode = False
End With
Application.CutCopyMode = False
Sheets("Form Payslip").Select
Range("A1").Select
MsgBox "Done!"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Web KT
Back
Top Bottom