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