Split file thành nhiều file mới

[babymyl3]

Chào mọi người ạ, tình hình e nhận được file phụ lục công ty và yêu cầu phải tách nhỏ ra từng file theo tên nhân viên. Em có xem thử các bài đăng dùng code VBA nhưng lại không biết làm lên mò mãi không được, có ai hỗ trợ tách file hộ e với ạ

 

[babymyl3]

Mình có dùng đoạn code này nhưng không biết làm sao lấy tên nv của file mình cho đúng

Sub newSplitFile()
On Error Resume Next
Application.ScreenUpdating = False
Selection.EndKey Unit:=wdStory
Selection.InsertBreak Type:=wdPageBreak
Pages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
ChangeFileOpenDirectory ActiveDocument.Path
j = 0
For i = 1 To Pages - 1
Selection.HomeKey Unit:=wdStory
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Selection.TypeBackspace
Selection.HomeKey Unit:=wdStory
Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:=""
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Stt = Mid(Selection.Text, InStr(1, Selection.Text, ": ") + 1, Len(Selection.Text))

Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:=""
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
tennv = Mid(Selection.Text, InStr(1, Selection.Text, ": ") + 1, Len(Selection.Text))
Fname = "File_" & Stt & "_" & tennv & ".docx"
If Fname <> "File__.docx" Then j = j + 1
ActiveDocument.SaveAs2 FileName:=Fname, FileFormat:=wdFormatXMLDocument, LockComments:=False, _
Password:="", AddToRecentFiles:=True, WritePassword:="", _
ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=14

Selection.WholeStory
Selection.Paste
Next i
Application.ScreenUpdating = True

MsgBox "Done!" & Chr(13) & "There's " & j & " page(s) were saved !"

End Sub

 

[befaint]

 

[be_09]

Chào mọi người ạ, tình hình e nhận được file phụ lục công ty và yêu cầu phải tách nhỏ ra từng file theo tên nhân viên. Em có xem thử các bài đăng dùng code VBA nhưng lại không biết làm lên mò mãi không được, có ai hỗ trợ tách file hộ e với ạ

Tạo 1 Folder chứa File phu luc, Mở File phu luc rồi gán code sau vào Module, khi chạy code nó sẽ tạo File mới là Phuluc_NV_1 (theo thứ tự trang), code hơi chậm nhưng có thể đáp ứng cái đang cần.

Sub TachFile_Word()
    Dim NhieuTrang As Document
    Dim TaoFileMoi As Document
    Dim SaoChep As Range
    Dim TrangHienTai As Integer
    Dim DemSoTrang As Integer
    Dim DatTenFileMoi As String
    Application.ScreenUpdating = False
    Set NhieuTrang = ActiveDocument
    Set SaoChep = NhieuTrang.Range
    TrangHienTai = 1
    'Dém só trang
    DemSoTrang = NhieuTrang.Content.ComputeStatistics(wdStatisticPages)
        Do Until TrangHienTai > DemSoTrang
        If TrangHienTai = DemSoTrang Then
            SaoChep.End = ActiveDocument.Range.End 'Sao chep và dùng tai trang cuói
            Else
            'Chon trang bat dàu
            Selection.GoTo wdGoToPage, wdGoToAbsolute, TrangHienTai + 1
            SaoChep.End = Selection.Start
        End If
        SaoChep.Copy 'copy 1 trang
        Set TaoFileMoi = Documents.Add 'Tao mói File Word
        TaoFileMoi.Range.Paste 'paste vào File mói
        'Xóa ngát trang
        TaoFileMoi.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
        'Dat ten File mói theo thú tu trang
        DatTenFileMoi = Replace(NhieuTrang.FullName, ".doc", "_" & Right$("NV_" & TrangHienTai, 8) & ".doc")
        TaoFileMoi.SaveAs DatTenFileMoi 'save File mói tao
        TrangHienTai = TrangHienTai + 1 'Chuyen trang tiép theo
        TaoFileMoi.Close 'close File mói tao
        SaoChep.Collapse wdCollapseEnd
        Loop
    Application.ScreenUpdating = True
    'Thoát bo nhó.
    Set NhieuTrang = Nothing
    Set TaoFileMoi = Nothing
    Set SaoChep = Nothing
End Sub

 

[babymyl3]

Cảm ơn để mình thử

Bài đã được tự động gộp: 28/1/19

Tạo 1 Folder chứa File phu luc, Mở File phu luc rồi gán code sau vào Module, khi chạy code nó sẽ tạo File mới là Phuluc_NV_1 (theo thứ tự trang), code hơi chậm nhưng có thể đáp ứng cái đang cần.

Sub TachFile_Word()
    Dim NhieuTrang As Document
    Dim TaoFileMoi As Document
    Dim SaoChep As Range
    Dim TrangHienTai As Integer
    Dim DemSoTrang As Integer
    Dim DatTenFileMoi As String
    Application.ScreenUpdating = False
    Set NhieuTrang = ActiveDocument
    Set SaoChep = NhieuTrang.Range
    TrangHienTai = 1
    'Dém só trang
    DemSoTrang = NhieuTrang.Content.ComputeStatistics(wdStatisticPages)
        Do Until TrangHienTai > DemSoTrang
        If TrangHienTai = DemSoTrang Then
            SaoChep.End = ActiveDocument.Range.End 'Sao chep và dùng tai trang cuói
            Else
            'Chon trang bat dàu
            Selection.GoTo wdGoToPage, wdGoToAbsolute, TrangHienTai + 1
            SaoChep.End = Selection.Start
        End If
        SaoChep.Copy 'copy 1 trang
        Set TaoFileMoi = Documents.Add 'Tao mói File Word
        TaoFileMoi.Range.Paste 'paste vào File mói
        'Xóa ngát trang
        TaoFileMoi.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
        'Dat ten File mói theo thú tu trang
        DatTenFileMoi = Replace(NhieuTrang.FullName, ".doc", "_" & Right$("NV_" & TrangHienTai, 8) & ".doc")
        TaoFileMoi.SaveAs DatTenFileMoi 'save File mói tao
        TrangHienTai = TrangHienTai + 1 'Chuyen trang tiép theo
        TaoFileMoi.Close 'close File mói tao
        SaoChep.Collapse wdCollapseEnd
        Loop
    Application.ScreenUpdating = True
    'Thoát bo nhó.
    Set NhieuTrang = Nothing
    Set TaoFileMoi = Nothing
    Set SaoChep = Nothing
End Sub

Bác ơi có làm cách nào lấy tên n.v đưa ra làm tên file không ạ