[Giúp đỡ] Tìm kiếm, lọc và lấy dữ liệu từ nhiều file Word vào 1 file excel

em xin chân thành cảm ơn ạ.

Hiện tại em có nhiều file word có chứa dữ liệu cần lầy để thêm vào 1 file Excel.
Các dữ liệu muốn lấy nằm đúng vị trí thứ tự giống nhau trong các file word.
(Mẫu e đính kèm theo)
Kính nhờ các bác hướng dẫn em viết VBA hoặc làm cách nào để mình lấy dữ liệu qua excel được ạ, em xin chân thành cảm ơn ạ.

Bấm nút Chạy code -> duyệt tìm và chọn những file Word cần lấy dữ liệu -> bấm Open => Xong.

Sub GetDataWord()
    Dim WordApp As Object, myDoc As Object
    Dim i&, aTitle, aRes, MyPath, FullName

aTitle = Range("B1:L1").Value
    ReDim aRes(1 To UBound(aTitle, 2))
    Application.ScreenUpdating = False
    MyPath = Application.GetOpenFilename(Title:="Chon cac file Word can lay du lieu.", _
    FileFilter:="Excel Files *.doc* (*.doc*),", MultiSelect:=True)
    On Error GoTo WithArray
    If MyPath = False Then
        MsgBox "Ban chua chon file nào.", vbExclamation, "Sorry!"
        Exit Sub
    Else
WithArray:
        Set WordApp = CreateObject("Word.Application")
        For Each FullName In MyPath
            Set myDoc = WordApp.Documents.Open(FullName)
            WordApp.Visible = False
            With WordApp.Selection
                .HomeKey Unit:=6                              'wdStory
                For i = 1 To UBound(aTitle, 2)
                    If i = 1 Then
                        .Find.Text = Left(aTitle(1, i), 2)
                    Else
                        .Find.Text = aTitle(1, i)
                    End If
                    .Find.Execute: .MoveRight Unit:=1, Count:=2
                    If i = 1 Then
                        .MoveRight Unit:=2, Count:=6, Extend:=1
                    ElseIf i = UBound(aTitle, 2) Then
                        .MoveDown Unit:=4, Extend:=1
                        .Find.Text = "ngày": .Find.Execute
                        .MoveDown Unit:=4, Extend:=1
                    Else
                        .MoveDown Unit:=4, Extend:=1
                    End If
                    aRes(i) = Trim(.Range)
                    .MoveRight Unit:=1, Count:=1
                Next
            End With
            Range("B65536").End(xlUp).Offset(1).Resize(1, UBound(aRes)) = aRes
            myDoc.Close False
        Next FullName
    End If
    WordApp.Quit: Set myDoc = Nothing: Set WordApp = Nothing
    Application.ScreenUpdating = True
    MsgBox "Xong."
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-%C4%91%E1%BB%A1-t%C3%ACm-ki%E1%BA%BFm-l%E1%BB%8Dc-v%C3%A0-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-nhi%E1%BB%81u-file-word-v%C3%A0o-1-file-excel.166249/

Khóa học SprinGO phù hợp

Ứng dụng AI và Chat GPT trong Quản trị nhân sự

Học xong khóa này, học viên có thể: Hiểu đúng bản chất AI, các nhóm AI phổ biến và cách AI “hoạt động” ở...

Xem khóa học