Private Const wdPropertyPages = 14
Private Const wdGoToPage = 1
Private Const wdGoToAbsolute = 1
Private Const wdParagraph = 4
Sub sort_word_pages()
Const wordfile1 = "WORD1.docx"
Const wordfile2 = "WORD2.docx"
Dim k As Long, r As Long, count As Long, text As String, Arr()
Dim WordApp As Object, doc As Object, doc2 As Object
Dim nPagesCount As Long, pages_range As Object
With ThisWorkbook.Worksheets("Sheet1")
Arr = .Range("A1:A" & .Cells(Rows.count, "A").End(xlUp).Row + 1).Value
End With
ReDim Preserve Arr(1 To UBound(Arr), 1 To 2)
' khoi dong server WORD
Set WordApp = CreateObject("Word.Application")
' WordApp.Visible = True
Set doc = WordApp.documents.Open(ThisWorkbook.Path & "\" & wordfile1)
' so trang trong Document nguon
nPagesCount = doc.BuiltinDocumentProperties(wdPropertyPages)
For k = 1 To nPagesCount
' nhay toi cac trang lien tiep
WordApp.Selection.GoTo wdGoToPage, wdGoToAbsolute, k
' mo rong chon ra ca paragraph dau tien
WordApp.Selection.Expand wdParagraph
' noi dung cua paragraph dau tien
text = WordApp.Selection.Range.text
For r = 1 To UBound(Arr) - 1
' tim tung gia tri trong cot A cua Excel xem co trong noi dung hien hanh khong.
' Neu co thi ghi chi so trang vao cot thu 2 va thoat
If InStr(1, text, Arr(r, 1), vbTextCompare) Then
Arr(r, 2) = k
count = count + 1
Exit For
End If
Next r
If count = UBound(Arr) - 1 Then Exit For
Next k
' chi di tiep khi co it nhat 1 trang khop voi muc trong cot A cua Excel
If count Then
Set doc2 = WordApp.documents.Add
count = 0
For r = 1 To UBound(Arr) - 1
' doc ra vi tri cua trang
k = Arr(r, 2)
' neu vi tri > 0 thi co nghia la trang o vi tri do khop voi muc hien hanh o cot 1 cua Arr
If k Then
count = count + 1
' kich hoat tap tin nguon
doc.Activate
WordApp.Selection.End = 0
' nhay toi trang o vi tri k
WordApp.Selection.GoTo wdGoToPage, wdGoToAbsolute, k
' doc noi dung cua trang va copy vao clipboard
Set pages_range = WordApp.Selection.Range
pages_range.End = WordApp.Selection.Bookmarks("\Page").Range.End
pages_range.Copy
' kich hoat tap tin ket qua
doc2.Activate
' neu so trang hien hanh nho hon count (so trang can co) thi them 1 trang moi
If doc2.BuiltinDocumentProperties(wdPropertyPages) < count Then WordApp.Selection.InsertNewPage
' nhay toi trang cuoi cung hien hanh
WordApp.Selection.GoTo wdGoToPage, wdGoToAbsolute, count
' dan tu clipboard
WordApp.Selection.Paste
End If
Next r
doc2.Saveas2 ThisWorkbook.Path & "\" & wordfile2
doc.Saved = True
Else
doc.Saveas2 ThisWorkbook.Path & "\" & wordfile2
End If
WordApp.Quit
Set WordApp = Nothing
Set doc = Nothing
Set doc2 = Nothing
End Sub
