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

[phucthanh11111989]

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 ạ.

 

[Hoàng Tuấn 868]

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ình thường mình vẫn copy rồi dán sang, nếu nhiều thì nâng tốc độ thao tác lên thôi.

 

[phucthanh11111989]

Bình thường mình vẫn copy rồi dán sang, nếu nhiều thì nâng tốc độ thao tác lên thôi.

Dạ có tầm mấy nghìn file ạ. Nên không thể làm thủ công được ạ. E cảm ơn đã rep ạ

 

[snow25]

Bình thường mình vẫn copy rồi dán sang, nếu nhiều thì nâng tốc độ thao tác lên thôi.

Dùng VBA có mở được word rồi đọc như mở file txt,Csv không nhỉ.

 

[Hoàng Tuấn 868]

Dùng VBA có mở được word rồi đọc như mở file txt,Csv không nhỉ.

Từ file excel mở lần lượt từng file word, copy sang sheet tạm file excel rồi cho chạy vào sheet mẫu là được thôi anh.

 

[phucthanh11111989]

Từ file excel mở lần lượt từng file word, copy sang sheet tạm file excel rồi cho chạy vào sheet mẫu là được thôi anh.

Dạ do số lượng file quá lớn nên không mở lần lượt đc ạ.

 

[Hoàng Tuấn 868]

không mở lần lượt đc ạ.

Mở bằng VBA mà, nhưng bạn viết tắt nên mình không tham gia bài này nữa.

 

[hvnhpro]

mình chưa down file về nhưng hỏi bạn chút.
Ví dụ từ "hà nội" nó xuất hiện nhiều lần trong file word thì lấy từ đầu tiên theo cách tìm kiếm từ trang 1 trở đi đúng ko. bạn miêu tả rõ, nếu giống cách mình đang làm mình gửi code cho bạn tham khảo

 

[GIANG 1e34]

Bạn chọn hết tất cả các file rồi convert sang PDF. rồi export 1 file PDF đã combine những file convert trước đó sang các sheet riêng lẻ hoặc 1 sheet để dễ lấy data. dùng xlookup là lấy được data theo bạn muốn
Thân ái!

 

[phucthanh11111989]

mình chưa down file về nhưng hỏi bạn chút.
Ví dụ từ "hà nội" nó xuất hiện nhiều lần trong file word thì lấy từ đầu tiên theo cách tìm kiếm từ trang 1 trở đi đúng ko. bạn miêu tả rõ, nếu giống cách mình đang làm mình gửi code cho bạn tham khảo

Dạ trong các file word có các từ khoá.
Nó nằm ở đầu tiên của các dòng:
- số điện thoại: 0987475777
- ngày hẹn trả: 14 tháng 07 năm 2023

Ý là em muốn lấy các dữ liệu:
0987475777, 14 tháng 07 năm 2023 vào các ô thứ tự trong excel ạ.

Bài đã được tự động gộp: 20/7/23

mình chưa down file về nhưng hỏi bạn chút.
Ví dụ từ "hà nội" nó xuất hiện nhiều lần trong file word thì lấy từ đầu tiên theo cách tìm kiếm từ trang 1 trở đi đúng ko. bạn miêu tả rõ, nếu giống cách mình đang làm mình gửi code cho bạn tham khảo

Chó em xin code tham khảo với ạ. Cảm ơn ạ

Bài đã được tự động gộp: 20/7/23

Bạn chọn hết tất cả các file rồi convert sang PDF. rồi export 1 file PDF đã combine những file convert trước đó sang các sheet riêng lẻ hoặc 1 sheet để dễ lấy data. dùng xlookup là lấy được data theo bạn muốn
Thân ái!

Là conver các file word đó qua pdf, lúc đó đang có nhiều file pdf. Xong nối sao để qua excel được ạ?

 

[hvnhpro]

không giống mình tưởng tượng lắm.
gửi bạn tham khảo code copy từ word sang excel, mình sưu tầm được

Sub CopyWord()
    Dim objWord As Word.Application
'Nho them VBAproject- Microsoft word ... Object Library

    Dim objDoc As Word.Document
    Dim RgDoc, RgStart, RgEnd, RgCopy As Word.Range
    Set objWord = New Word.Application
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Word Documents", "*.*"
        If .Show = -1 Then
Dim i As Long
For i = 1 To .SelectedItems.Count

    Set objDoc = objWord.Documents.Open(.SelectedItems(i), ReadOnly:=True)
'---Bat dau doan copy
    Set RgStart = objDoc.Content
        If Not RgStart.Find.Execute("noi dung tim 1") Then
            Resume Next
        End If
   
'---ket thuc doan copy
    Set RgEnd = objDoc.Content
   
        Set RgEnd = objDoc.Content
    'RgEnd.Find.Execute ("noi dung tim 2")
        If Not RgEnd.Find.Execute(Sheets(wsName).Range("B2").Value) Then
            'Exit Sub
            Resume Next
        End If

'---Vung van ban word can copy
    Set RgCopy = objDoc.Range(RgStart.Start, RgEnd.End)
   
    RgCopy.Select
    objWord.Selection.Copy
   
'Vi tri paste trong excel
    Sheets(wsName).Range("A7").Select
    ActiveSheet.Paste
    objDoc.Close SaveChanges:=False
   
Next i

    objWord.Quit
        Else
            Exit Sub
        End If
    End With

End Sub

 

[tieutuvodanh192]

không giống mình tưởng tượng lắm.
gửi bạn tham khảo code copy từ word sang excel, mình sưu tầm được

Sub CopyWord()
    Dim objWord As Word.Application
    Dim objDoc As Word.Document
    Dim RgDoc, RgStart, RgEnd, RgCopy As Word.Range
    Set objWord = New Word.Application
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Word Documents", "*.*"
        If .Show = -1 Then
Dim i As Long
For i = 1 To .SelectedItems.Count

    Set objDoc = objWord.Documents.Open(.SelectedItems(i), ReadOnly:=True)
'---Bat dau doan copy
    Set RgStart = objDoc.Content
        If Not RgStart.Find.Execute("noi dung tim 1") Then
            Resume Next
        End If
  
'---ket thuc doan copy
    Set RgEnd = objDoc.Content
  
        Set RgEnd = objDoc.Content
    'RgEnd.Find.Execute ("noi dung tim 2")
        If Not RgEnd.Find.Execute(Sheets(wsName).Range("B2").Value) Then
            'Exit Sub
            Resume Next
        End If

'---Vung van ban word can copy
    Set RgCopy = objDoc.Range(RgStart.Start, RgEnd.End)
  
    RgCopy.Select
    objWord.Selection.Copy
  
'Vi tri paste trong excel
    Sheets(wsName)..Range("A7").Select
    ActiveSheet.Paste
    objDoc.Close SaveChanges:=False
  
Next i

    objWord.Quit
        Else
            Exit Sub
        End If
    End With

End Sub

Mình đã thử, code chạy khá tốt, thêm vòng lặp vào và xào chế thêm 1 xíu chắc sẽ đáp ứng được yêu cầu của thớt.

 

[phucthanh11111989]

Mình đã thử, code chạy khá tốt, thêm vòng lặp vào và xào chế thêm 1 xíu chắc sẽ đáp ứng được yêu cầu của thớt.

Dạ em cảm ơn ạ. Để e tìm hiểu xem sao, đoạn nào không hiểu em hỏi thêm
ạ

Bài đã được tự động gộp: 20/7/23

không giống mình tưởng tượng lắm.
gửi bạn tham khảo code copy từ word sang excel, mình sưu tầm được

Sub CopyWord()
    Dim objWord As Word.Application
    Dim objDoc As Word.Document
    Dim RgDoc, RgStart, RgEnd, RgCopy As Word.Range
    Set objWord = New Word.Application
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Word Documents", "*.*"
        If .Show = -1 Then
Dim i As Long
For i = 1 To .SelectedItems.Count

    Set objDoc = objWord.Documents.Open(.SelectedItems(i), ReadOnly:=True)
'---Bat dau doan copy
    Set RgStart = objDoc.Content
        If Not RgStart.Find.Execute("noi dung tim 1") Then
            Resume Next
        End If
   
'---ket thuc doan copy
    Set RgEnd = objDoc.Content
   
        Set RgEnd = objDoc.Content
    'RgEnd.Find.Execute ("noi dung tim 2")
        If Not RgEnd.Find.Execute(Sheets(wsName).Range("B2").Value) Then
            'Exit Sub
            Resume Next
        End If

'---Vung van ban word can copy
    Set RgCopy = objDoc.Range(RgStart.Start, RgEnd.End)
   
    RgCopy.Select
    objWord.Selection.Copy
   
'Vi tri paste trong excel
    Sheets(wsName)..Range("A7").Select
    ActiveSheet.Paste
    objDoc.Close SaveChanges:=False
   
Next i

    objWord.Quit
        Else
            Exit Sub
        End If
    End With

End Sub

Cảm ơn bác đã chia sẻ ạ.

 

[phucthanh11111989]

E chạy báo lỗi chỗ :
Sub CopyWord()
Dim objWord As Word.Application
mặc dù đã vào tool tick vào obj này r ạ.

 

[hvnhpro]

E chạy báo lỗi chỗ :
Sub CopyWord()
Dim objWord As Word.Application
mặc dù đã vào tool tick vào obj này r ạ.

Bạn nhớ thêm VBAproject- Microsoft word ... Object Library vào file excel chạy marco này nhé.

 

[Maika8008]

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

 

[phucthanh11111989]

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

Chuẩn quá anh ơi, chạy rất ok và đúng ý em ạ, Tks tất cả các bác đã hỗ trợ ạ,