Cho em hỏi tách file word thành các file khác nhau, mỗi file tách ra là 2 trang

[tranphamhung1999]

Cho em hỏi tách file word thành các file khác nhau, mỗi file tách ra là 2 trang.
Tách các file ra 1 trang thì e dùng lệnh VBA dưới đây, nhưng giờ muốn tách thành các file 2 trang thì sửa thế nào ạ.
Em cảm ơn!
Sub tách file 1 trang:
Sub TachFile()
Application.ScreenUpdating = False
Dim Doc As Document, Pages As Long
Set Doc = ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.InsertBreak Type:=wdPageBreak
Selection.HomeKey Unit:=wdStory
Pages = Doc.BuiltInDocumentProperties(wdPropertyPages)
ChangeFileOpenDirectory ActiveDocument.Path
For i = 1 To Pages - 1
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
With Documents.Add
Selection.Paste
Selection.EndKey Unit:=wdStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If AscW(Selection.Text) = 12 Or AscW(Selection.Text) = 13 Or AscW(Selection.Text) = 22 Then Selection.TypeBackspace
.SaveAs VBA.Format(i + , "000") & Left(Doc.Name, InStrRev(Doc.Name, ".") - 1) & ".doc", 0
.Close
End With
Next
Application.ScreenUpdating = True
End Sub

 

[Nhattanktnn]

Cho em hỏi tách file word thành các file khác nhau, mỗi file tách ra là 2 trang.
Tách các file ra 1 trang thì e dùng lệnh VBA dưới đây, nhưng giờ muốn tách thành các file 2 trang thì sửa thế nào ạ.
Em cảm ơn!
Sub tách file 1 trang:
Sub TachFile()
Application.ScreenUpdating = False
Dim Doc As Document, Pages As Long
Set Doc = ActiveDocument
Selection.EndKey Unit:=wdStory
Selection.InsertBreak Type:=wdPageBreak
Selection.HomeKey Unit:=wdStory
Pages = Doc.BuiltInDocumentProperties(wdPropertyPages)
ChangeFileOpenDirectory ActiveDocument.Path
For i = 1 To Pages - 1
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
With Documents.Add
Selection.Paste
Selection.EndKey Unit:=wdStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If AscW(Selection.Text) = 12 Or AscW(Selection.Text) = 13 Or AscW(Selection.Text) = 22 Then Selection.TypeBackspace
.SaveAs VBA.Format(i + , "000") & Left(Doc.Name, InStrRev(Doc.Name, ".") - 1) & ".doc", 0
.Close
End With
Next
Application.ScreenUpdating = True
End Sub

Cũng không biết nhiều về code bên word nhưng mò mò làm đại cái này bạn chạy thử thế nào

Sub TachFile()
Application.ScreenUpdating = False
Dim Doc As Document, Pages As Long, iPages As Long, rgePages As Range, i As Long
Set Doc = ActiveDocument
Pages = Doc.BuiltInDocumentProperties(wdPropertyPages)
iPages = 1
Do While iPages <= Pages
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iPages
    Set rgePages = Selection.Range
    iPages = iPages + 2
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iPages - 1
    rgePages.End = Selection.Bookmarks("\Page").Range.End
    rgePages.Copy
    With Documents.Add
        Selection.Paste
        i = i + 1
        .SaveAs Format(i, "000") & Left(Doc.Name, InStrRev(Doc.Name, ".") - 1) & ".doc", 0
        .Close
    End With
Loop
Application.ScreenUpdating = True
End Sub

Phần saveas không rõ tên file gốc bạn thế nào nhưng nếu không có dấu chấm là bị lỗi đấy

 

[tranphamhung1999]

Cũng không biết nhiều về code bên word nhưng mò mò làm đại cái này bạn chạy thử thế nào

Sub TachFile()
Application.ScreenUpdating = False
Dim Doc As Document, Pages As Long, iPages As Long, rgePages As Range, i As Long
Set Doc = ActiveDocument
Pages = Doc.BuiltInDocumentProperties(wdPropertyPages)
iPages = 1
Do While iPages <= Pages
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iPages
    Set rgePages = Selection.Range
    iPages = iPages + 2
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=iPages - 1
    rgePages.End = Selection.Bookmarks("\Page").Range.End
    rgePages.Copy
    With Documents.Add
        Selection.Paste
        i = i + 1
        .SaveAs Format(i, "000") & Left(Doc.Name, InStrRev(Doc.Name, ".") - 1) & ".doc", 0
        .Close
    End With
Loop
Application.ScreenUpdating = True
End Sub

Phần saveas không rõ tên file gốc bạn thế nào nhưng nếu không có dấu chấm là bị lỗi đấy

Cảm ơn bro em thử được rồi nhưng có cái vấn đề là những file được tách ra nó ko lưu ở trong thư mục chứa file tổng mà nó lại tự lưu ở trong ổ C/Document.
Như cái sub tách 1 trang kia nó tự lưu vào file chứa thư mục tổng luôn.
Với lại còn 1 cái nữa là những file đc tách ra file nào cũng ra thêm trang thứ 3 trắng, thì có xoá đc cái trang trắng kia ko a.
Em trân trọng cảm ơn!