Lấy nội dung bất kỳ từ file Word chuyển vào Excel (dùng để tổng hợp)

Liên hệ QC MyVTV Add-ins

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Em mạo muội gửi bài này nhờ các bác trong diễn đàn hỗ trợ, chẳng là chỗ mình làm có nhiều file "Khai báo" bằng Word của nhiều người khi khai báo (có thể tên file khác nhau), em muốn lấy nội dung trong file Word tổng hợp vào file Excel tổng hợp, mà em thì không rành vụ lấy nội dung từ Word, mong các bác trong diễn đàn hỗ trợ giúp em nội dung này, Em cám ơn rất nhiều ah!
 

File đính kèm

  • Khai bao 1.docx
    11.7 KB · Đọc: 11
  • Khai bao 2.docx
    11.8 KB · Đọc: 10
  • Tong hop.xlsx
    8.9 KB · Đọc: 11

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Mình có tìm kiếm nhưng code này chỉ copy toàn bộ nội dung file Word vào từng sheet và cell được chọn, ai có thể giúp mình được không?

Option Explicit

Sub CopyFileRtfToExcel()
Dim wsNew As Worksheet
Dim vFile As Variant
Dim oWordApp As Object, oWordDoc As Object
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "File type", "*.docx"
.Title = "Choose one or more files docx"
If .Show <> 0 Then
Set oWordApp = CreateObject("Word.Application")
For Each vFile In .SelectedItems
With oWordApp
Set oWordDoc = .Documents.Open(Filename:=vFile)
.ActiveDocument.Select
.Selection.Copy
End With
With Sheets.Add(After:=Sheets(Sheets.Count))
.Range("A1").Select
.Paste
End With
oWordDoc.Close
Set oWordDoc = Nothing
Next vFile
oWordApp.Quit
Set oWordApp = Nothing
MsgBox "Finish", vbInformation, "---:: NOTICE ::---"
Else
MsgBox "Do NOTHING", vbCritical, "---:: Error ::---"
End If
End With
End Sub
 

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
4,250
Được thích
6,767
Em mạo muội gửi bài này nhờ các bác trong diễn đàn hỗ trợ, chẳng là chỗ mình làm có nhiều file "Khai báo" bằng Word của nhiều người khi khai báo (có thể tên file khác nhau), em muốn lấy nội dung trong file Word tổng hợp vào file Excel tổng hợp, mà em thì không rành vụ lấy nội dung từ Word, mong các bác trong diễn đàn hỗ trợ giúp em nội dung này, Em cám ơn rất nhiều ah!
1. Code bỏ qua các dòng trống nếu có, nhưng thứ tự dữ liệu trong tập tin Word phải luôn như trong tập tin ví dụ, tức Họ và tên, Năm sinh, Nơi sinh, ...

2. Code trong Module1. Nhấn nút "Chạy code" và chọn tất cả các tập tin Word cần lấy dữ liệu.
 

File đính kèm

  • Tong hop.xlsm
    19.6 KB · Đọc: 14

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
1. Code bỏ qua các dòng trống nếu có, nhưng thứ tự dữ liệu trong tập tin Word phải luôn như trong tập tin ví dụ, tức Họ và tên, Năm sinh, Nơi sinh, ...

2. Code trong Module1. Nhấn nút "Chạy code" và chọn tất cả các tập tin Word cần lấy dữ liệu.
Hay quá, em cám ơn bác nhiều, code chạy rất tuyệt ah, theo đúng nôi dung cần lấy, cái này giúp ích rất nhiều cho em để tổng hợp, một lần nữa em xin chân thành cám ơn bác batman1
 

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
4,250
Được thích
6,767
Hay quá, em cám ơn bác nhiều, code chạy rất tuyệt ah, theo đúng nôi dung cần lấy, cái này giúp ích rất nhiều cho em để tổng hợp, một lần nữa em xin chân thành cám ơn bác batman1
Lưu ý: code lấy tất cả các dòng có ký tự 2 chấm ":" - cụ thể là lấy dữ liệu sau dấu hai chấm. Vì thế phải là vd. Họ và tên: Nguyễn Văn A chứ không được phép Họ và tên - Nguyễn Văn A. Các dòng không cần lấy không được phép có ký tự 2 chấm ":"
 

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
1. Code bỏ qua các dòng trống nếu có, nhưng thứ tự dữ liệu trong tập tin Word phải luôn như trong tập tin ví dụ, tức Họ và tên, Năm sinh, Nơi sinh, ...

2. Code trong Module1. Nhấn nút "Chạy code" và chọn tất cả các tập tin Word cần lấy dữ liệu.
Bác batman ơi, nếu em muốn phát triển thêm để lấy nội dung khác với trong tờ khai báo này được không bác? ví dụ một cái file giống như thế này nè bác, bác có thể giúp em được không? Trong này em muốn lấy mấy cái chữ em bôi đỏ (trong tất cả file không phải chữ đỏ), em mong bác giúp đỡ em.
Bài đã được tự động gộp:

Lưu ý: code lấy tất cả các dòng có ký tự 2 chấm ":" - cụ thể là lấy dữ liệu sau dấu hai chấm. Vì thế phải là vd. Họ và tên: Nguyễn Văn A chứ không được phép Họ và tên - Nguyễn Văn A. Các dòng không cần lấy không được phép có ký tự 2 chấm ":"
Em có thấy một đoạn code nhưng chỉ lấy được một dòng thôi bác

Sub GetDataFromMSWordFiles()
Dim arrResult
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show Then
arrResult = ReadMSWordFiles(.SelectedItems(1))
Range("A1").Resize(UBound(arrResult, 1), 2).Value = arrResult
End If
End With
End Sub


Private Function ReadMSWordFiles(ByVal sFolder As String) As Variant
Dim FSO As Object, iFile As Object, arrResult(1 To 65000, 1 To 2), iIndex
Set FSO = CreateObject("Scripting.FileSystemObject")
With CreateObject("Word.Application")
.Visible = False
For Each iFile In FSO.GetFolder(sFolder).Files
If LCase(FSO.GetExtensionName(iFile)) & "x" Like "docx*" Then
iIndex = iIndex + 1
arrResult(iIndex, 1) = iFile
With .Documents.Open(iFile.Path)
arrResult(iIndex, 2) = .Paragraphs(4).Range.Text
.Close False
End With
End If
Next
.Quit
ReadMSWordFiles = arrResult
End With
Set FSO = Nothing
End Function
 

File đính kèm

  • 2232-PC-VP(07-6-2021).docx
    21.1 KB · Đọc: 6

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
4,250
Được thích
6,767
Có nghĩa đây là bài toán hoàn toàn mới?

Đừng đính kèm code làm gì vì tôi cần mô tả vấn đề, tôi không đọc code để đoán vấn đề. Mô tả thật kỹ. Thế thôi.

Đừng viết: "Đôi khi chỗ này có 1, 2 hoặc 3 chỉ đạo.". Hãy đính kèm vd. 3 tập tin Word để người khác nhận biết những chỗ nào là những đoạn không đổi, là cái khung bất di bất dịch, còn chỗ nào thay đổi. Tốt nhất là mô tả cấu trúc của tập tin Word. Nó gồm những phần nào, lần lượt thế nào. Vì chuyện lọc ra những kết quả phải dựa vào cấu trúc, vào việc xác định những đoạn không đổi. Cũng đính kèm tập tin Excel và điền bằng tay kết quả lấy từ 3 tập tin Word kia. Tôi không tự tạo tập tin Excel với tạo bảng có tiêu đề. Tôi không cầy hộ những chỗ bạn có thể tự cầy.
 

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Có nghĩa đây là bài toán hoàn toàn mới?

Đừng đính kèm code làm gì vì tôi cần mô tả vấn đề, tôi không đọc code để đoán vấn đề. Mô tả thật kỹ. Thế thôi.

Đừng viết: "Đôi khi chỗ này có 1, 2 hoặc 3 chỉ đạo.". Hãy đính kèm vd. 3 tập tin Word để người khác nhận biết những chỗ nào là những đoạn không đổi, là cái khung bất di bất dịch, còn chỗ nào thay đổi. Tốt nhất là mô tả cấu trúc của tập tin Word. Nó gồm những phần nào, lần lượt thế nào. Vì chuyện lọc ra những kết quả phải dựa vào cấu trúc, vào việc xác định những đoạn không đổi. Cũng đính kèm tập tin Excel và điền bằng tay kết quả lấy từ 3 tập tin Word kia. Tôi không tự tạo tập tin Excel với tạo bảng có tiêu đề. Tôi không cầy hộ những chỗ bạn có thể tự cầy.
Cám ơn bác đã quan tâm, do em không có máy tính ở nhà, mai em lên cơ quan sớm em gửi bác file cụ thể, do nó lấy các nội dung mà vừa có tính chất không đổi vừa có tính chất thay đổi nên em không biết phải làm thế nào, em hiểu ý bác, em sẽ làm tay mẫu một kết quả sẵn.
 

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Bác
Có nghĩa đây là bài toán hoàn toàn mới?

Đừng đính kèm code làm gì vì tôi cần mô tả vấn đề, tôi không đọc code để đoán vấn đề. Mô tả thật kỹ. Thế thôi.

Đừng viết: "Đôi khi chỗ này có 1, 2 hoặc 3 chỉ đạo.". Hãy đính kèm vd. 3 tập tin Word để người khác nhận biết những chỗ nào là những đoạn không đổi, là cái khung bất di bất dịch, còn chỗ nào thay đổi. Tốt nhất là mô tả cấu trúc của tập tin Word. Nó gồm những phần nào, lần lượt thế nào. Vì chuyện lọc ra những kết quả phải dựa vào cấu trúc, vào việc xác định những đoạn không đổi. Cũng đính kèm tập tin Excel và điền bằng tay kết quả lấy từ 3 tập tin Word kia. Tôi không tự tạo tập tin Excel với tạo bảng có tiêu đề. Tôi không cầy hộ những chỗ bạn có thể tự cầy.
Em đã tạo một mẫu kết quả với nội dung được ghi trong file đính kèm, em gửi bác (những chỗ bôi đỏ là chỗ em cần lấy) đưa vào các cột có sẵn, bác giúp em nha, tại 1 ngày em phải giải quyết có khi gần 1000 PC như thế này đó bác (các file này do 1 bên khác tạo ra theo chương trình quản lý nội dung trên webform, em chỉ xuất file ra được thôi. Em cám ơn bác rất nhiều.
 

File đính kèm

  • Theo doi chi dao.rar
    62.5 KB · Đọc: 8

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
4,250
Được thích
6,767
Yêu cầu:

1. Các dòng cần lấy phải theo đúng thứ tự như sau, và bắt đầu bằng các tiền tố được liệt kê:
Số: ...
Quận, ngày ...
Căn cứ Văn bản số: ...
Ngày: ...
Của: ...
Về việc: ...
...

Giữa các dòng này được phép có những dòng trống.

2. Riêng đoạn cuối có nhiều khúc với số lượng thay đổi thì để có thể xác định chúng thì mỗi dòng phải bắt đầu bằng ký tự gạch đầu dòng, ở trên bàn phím là phím sau phím 0 (phím "-" khi cần gõ số âm). Code sẽ chỉ lấy tất cả các dòng bắt đầu bằng "-".

Có thể thay vì "-" thì code xác định lấy tất cả các dòng sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên. Nhưng dòng cuối là chữ tiếng Việt nên có thể có người nhập không chuẩn, vd. nhập bằng unicode dựng sẵn còn code dùng unicode tổ hợp để dò, hoặc ngược lại. Lúc đó sẽ không dò đúng được. Nói chung để xử lý thì mất công. Vậy yêu cầu các dòng cần lấy phải bắr đầu bằng "-".
 

File đính kèm

  • Theo doi PC chi dao(tonghop).xlsm
    23.7 KB · Đọc: 11

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Yêu cầu:

1. Các dòng cần lấy phải theo đúng thứ tự như sau, và bắt đầu bằng các tiền tố được liệt kê:
Số: ...
Quận, ngày ...
Căn cứ Văn bản số: ...
Ngày: ...
Của: ...
Về việc: ...
...

Giữa các dòng này được phép có những dòng trống.

2. Riêng đoạn cuối có nhiều khúc với số lượng thay đổi thì để có thể xác định chúng thì mỗi dòng phải bắt đầu bằng ký tự gạch đầu dòng, ở trên bàn phím là phím sau phím 0 (phím "-" khi cần gõ số âm). Code sẽ chỉ lấy tất cả các dòng bắt đầu bằng "-".

Có thể thay vì "-" thì code xác định lấy tất cả các dòng sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên. Nhưng dòng cuối là chữ tiếng Việt nên có thể có người nhập không chuẩn, vd. nhập bằng unicode dựng sẵn còn code dùng unicode tổ hợp để dò, hoặc ngược lại. Lúc đó sẽ không dò đúng được. Nói chung để xử lý thì mất công. Vậy yêu cầu các dòng cần lấy phải bắr đầu bằng "-".
Em cám ơn bác rất nhiều, hiệu quả thật tốt, quả thật là form khi các bạn bên Tổ HC đánh vào thì nội dung hơi lung tung, có khi các dòng không bắt đầu bằng "-", tuy nhiên, các dòng sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên là theo một form sẵn, nên khi em thử điều chỉnh nội dung chỗ giao nhiệm vụ, bỏ "-" và chạy lại thì quả thật cột "Giao nhiệm vụ" không ra số liệu, nhờ bác xem lại giúp em với
 

File đính kèm

  • Untitled.png
    Untitled.png
    178.4 KB · Đọc: 7

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
4,250
Được thích
6,767
Em cám ơn bác rất nhiều, hiệu quả thật tốt, quả thật là form khi các bạn bên Tổ HC đánh vào thì nội dung hơi lung tung, có khi các dòng không bắt đầu bằng "-", tuy nhiên, các dòng sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên là theo một form sẵn, nên khi em thử điều chỉnh nội dung chỗ giao nhiệm vụ, bỏ "-" và chạy lại thì quả thật cột "Giao nhiệm vụ" không ra số liệu, nhờ bác xem lại giúp em với
Thì tôi nói quá rõ còn gì. Code chỉ lấy các dòng có "-" ở đầu. Nếu không có "-" thì không lấy. Tôi cảnh báo rồi mà. Còn nếu muốn lấy sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên thì tôi sẽ sửa.

Mã:
Sub tong_hop()
Const wdCollapseEnd = 0
Dim k As Long, c As Long, lastRow As Long, text As String, files, result(), p As Object
Dim wordApp As Object, wordDoc As Object, wordSelection As Object
    files = Application.GetOpenFilename("Word Files (*.docx), *.docx", , , , True)
    If Not IsArray(files) Then Exit Sub
    lastRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    Set wordApp = CreateObject("Word.Application")
    ReDim result(1 To UBound(files), 1 To 9)
    For k = 1 To UBound(files)
        Set p = Nothing
        Set wordDoc = wordApp.Documents.Open(files(k))
        Set wordSelection = wordApp.Selection
        result(k, 1) = k + lastRow - 2
        With wordSelection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = "S*:"
            .MatchWildcards = True
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 2) = Trim(Replace(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "Qu*n"
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 3) = Trim(Replace(Replace(text, Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "C[!H]*n c*:"
            If .Execute Then Set p = wordSelection.Paragraphs(1)
        End With
        If Not p Is Nothing Then
            c = 5
            Do While c < 9 And Not p Is Nothing
                If c < 9 Then
                    text = p.Range.text
                    If Len(text) > 5 Then
                        text = Trim(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""))
                        If c = 6 Then
                            result(k, c) = CDate(text)
                        Else
                            result(k, c) = text
                        End If
                        c = c + 1
                    End If
                    Set p = p.Next
                Else
                    Exit Do
                End If
            Loop
            If Not p Is Nothing Then
                Set p = p.Next
                text = ""
                Do While Not p Is Nothing
                    If p.Range.text Like "*th*c hi*n theo*" Then
                        Exit Do
                    ElseIf Len(p.Range.text) > 4 Then
                        text = text & p.Range.text & vbCrLf
                    End If
                    Set p = p.Next
                Loop
                result(k, 9) = text
            End If
        End If
    Next k
    Sheet1.Cells(Rows.Count, "B").End(xlUp).Offset(1, -1).Resize(UBound(result, 1), UBound(result, 2)).Value = result
    
    wordApp.Quit
    Set wordSelection = Nothing
    Set wordDoc = Nothing
    Set wordApp = Nothing
End Sub
 
Lần chỉnh sửa cuối:

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Thì tôi nói quá rõ còn gì. Code chỉ lấy các dòng có "-" ở đầu. Nếu không có "-" thì không lấy. Tôi cảnh báo rồi mà. Còn nếu muốn lấy sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên thì tôi sẽ sửa.

Mã:
Sub tong_hop()
Const wdCollapseEnd = 0
Dim k As Long, c As Long, lastRow As Long, text As String, files, result(), p As Object
Dim wordApp As Object, wordDoc As Object, wordSelection As Object
    files = Application.GetOpenFilename("Word Files (*.docx), *.docx", , , , True)
    If Not IsArray(files) Then Exit Sub
    lastRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    Set wordApp = CreateObject("Word.Application")
    ReDim result(1 To UBound(files), 1 To 9)
    For k = 1 To UBound(files)
        Set p = Nothing
        Set wordDoc = wordApp.Documents.Open(files(k))
        Set wordSelection = wordApp.Selection
        result(k, 1) = k + lastRow - 2
        With wordSelection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = "S*:"
            .MatchWildcards = True
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 2) = Trim(Replace(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "Qu*n"
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 3) = Trim(Replace(Replace(text, Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "C[!H]*n c*:"
            If .Execute Then Set p = wordSelection.Paragraphs(1)
        End With
        If Not p Is Nothing Then
            c = 5
            Do While c < 9 And Not p Is Nothing
                If c < 9 Then
                    text = p.Range.text
                    If Len(text) > 5 Then
                        text = Trim(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""))
                        If c = 6 Then
                            result(k, c) = CDate(text)
                        Else
                            result(k, c) = text
                        End If
                        c = c + 1
                    End If
                    Set p = p.Next
                Else
                    Exit Do
                End If
            Loop
            If Not p Is Nothing Then
                Set p = p.Next
                text = ""
                Do While Not p Is Nothing
                    If p.Range.text Like "*th*c hi*n theo*" Then
                        Exit Do
                    ElseIf Len(p.Range.text) > 4 Then
                        text = text & p.Range.text & vbCrLf
                    End If
                    Set p = p.Next
                Loop
                result(k, 9) = text
            End If
        End If
    Next k
    Sheet1.Cells(Rows.Count, "B").End(xlUp).Offset(1, -1).Resize(UBound(result, 1), UBound(result, 2)).Value = result
   
    wordApp.Quit
    Set wordSelection = Nothing
    Set wordDoc = Nothing
    Set wordApp = Nothing
End Sub
Em cám ơn bác rất nhiều vì đã quan tâm chủ đề này, như em nói ở trên hiện tại em không có máy tính (do bị hư chưa kiếm mua lại được hi hi) nên dạo này em phải lên cơ quan làm việc, em chưa xem được nội dung, nên không phản hồi lại kịp bác, mong bác thông cảm.
 

thesaintzero

Thành viên hoạt động
Tham gia ngày
16 Tháng ba 2009
Bài viết
149
Được thích
5
Em cám ơn bác
Thì tôi nói quá rõ còn gì. Code chỉ lấy các dòng có "-" ở đầu. Nếu không có "-" thì không lấy. Tôi cảnh báo rồi mà. Còn nếu muốn lấy sau Văn phòng HĐND và UBND ... và trước Đề nghị các đơn vị thực hiện theo ý kiến chỉ đạo trên thì tôi sẽ sửa.

Mã:
Sub tong_hop()
Const wdCollapseEnd = 0
Dim k As Long, c As Long, lastRow As Long, text As String, files, result(), p As Object
Dim wordApp As Object, wordDoc As Object, wordSelection As Object
    files = Application.GetOpenFilename("Word Files (*.docx), *.docx", , , , True)
    If Not IsArray(files) Then Exit Sub
    lastRow = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    Set wordApp = CreateObject("Word.Application")
    ReDim result(1 To UBound(files), 1 To 9)
    For k = 1 To UBound(files)
        Set p = Nothing
        Set wordDoc = wordApp.Documents.Open(files(k))
        Set wordSelection = wordApp.Selection
        result(k, 1) = k + lastRow - 2
        With wordSelection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .text = "S*:"
            .MatchWildcards = True
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 2) = Trim(Replace(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "Qu*n"
            If .Execute Then
                text = wordSelection.Paragraphs(1).Range.text
                result(k, 3) = Trim(Replace(Replace(text, Chr(13), ""), Chr(7), ""))
            End If
            wordSelection.Collapse wdCollapseEnd
            .text = "C[!H]*n c*:"
            If .Execute Then Set p = wordSelection.Paragraphs(1)
        End With
        If Not p Is Nothing Then
            c = 5
            Do While c < 9 And Not p Is Nothing
                If c < 9 Then
                    text = p.Range.text
                    If Len(text) > 5 Then
                        text = Trim(Replace(Mid(text, InStr(1, text, ":") + 1), Chr(13), ""))
                        If c = 6 Then
                            result(k, c) = CDate(text)
                        Else
                            result(k, c) = text
                        End If
                        c = c + 1
                    End If
                    Set p = p.Next
                Else
                    Exit Do
                End If
            Loop
            If Not p Is Nothing Then
                Set p = p.Next
                text = ""
                Do While Not p Is Nothing
                    If p.Range.text Like "*th*c hi*n theo*" Then
                        Exit Do
                    ElseIf Len(p.Range.text) > 4 Then
                        text = text & p.Range.text & vbCrLf
                    End If
                    Set p = p.Next
                Loop
                result(k, 9) = text
            End If
        End If
    Next k
    Sheet1.Cells(Rows.Count, "B").End(xlUp).Offset(1, -1).Resize(UBound(result, 1), UBound(result, 2)).Value = result
   
    wordApp.Quit
    Set wordSelection = Nothing
    Set wordDoc = Nothing
    Set wordApp = Nothing
End Sub
Em cám ơn bác rất nhiều!!!, file chạy rất tuyệt :):):)
 
Top Bottom