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