Function dulieuPXK(docFilename, sodong_ketqua As Long, ngaythang())
Dim filename As String, text As String, ma As String, soPhieu As String, ngay As String
Dim k As Long, n As Long, r As Long, c As Long, sodong As Long
Dim ketqua(), wordApp As Object, doc As Object
sodong_ketqua = 0
ngay = "yyyy-mm-dd"
On Error Resume Next
Set wordApp = CreateObject("Word.Application")
' wordApp.Visible = True
If Err.Number Then Exit Function
ReDim ketqua(1 To 500 * UBound(docFilename), 1 To 11) ' gia thiet la moi tap tin Word cho mang co 500 dong ket qua
ReDim ngaythang(1 To UBound(docFilename), 1 To 2)
For k = 1 To UBound(docFilename)
Set doc = wordApp.documents.Open(docFilename(k))
soPhieu = ""
With doc.Sections.First.Headers(2).Range.Paragraphs
For r = 1 To .Count
text = .Item(r).Range.text
Mid(text, 2, 1) = "o" ' bien ky tu thu 2 thanh "o"
If Mid(text, 1, 4) = "So: " Then
soPhieu = Trim(Mid(text, 5, Len(text) - 5))
End If
If soPhieu <> "" Then
If Mid(text, 1, 6) = "(oheo " Then ' khong phai la "(Theo " ma la "(oheo " vi truoc do bien ky tu thu 2 cua text thanh "o"
text = Application.Trim(Mid(text, InStr(1, text, "Ng")))
n = InStr(1, text, " ") + 1
Mid(ngay, 9, 2) = Mid(text, n, 2)
n = InStr(n + 3, text, " ") + 1
Mid(ngay, 6, 2) = Mid(text, n, 2)
n = InStr(n + 3, text, " ") + 1
Mid(ngay, 1, 4) = Mid(text, n, 4)
ngaythang(k, 1) = soPhieu
ngaythang(k, 2) = ngay
Exit For
End If
End If
Next r
If r > .Count Then
sodong_ketqua = 0
MsgBox "Tap tin " & docFilename(k) & " co cau truc khong hop le"
Exit Function
End If
End With
With doc.Tables(2)
sodong = .Rows.Count - 3
For r = 1 To sodong
ketqua(sodong_ketqua + r, 1) = Replace(.Cell(r + 3, 3).Range.text, Chr(7), "")
ketqua(sodong_ketqua + r, 2) = Replace(.Cell(r + 3, 2).Range.text, Chr(7), "")
For c = 3 To 8
ketqua(sodong_ketqua + r, c) = Replace(.Cell(r + 3, c + 1).Range.text, Chr(7), "")
If c > 6 Then ketqua(sodong_ketqua + r, c) = CDbl(Replace(ketqua(sodong_ketqua + r, c), ".", "")) ' Don gia, Thanh tien
Next c
ketqua(sodong_ketqua + r, 9) = soPhieu
ma = doc.Tables(1).Cell(5, 1).Range.text
ketqua(sodong_ketqua + r, 10) = Replace(Mid(ma, InStr(1, ma, ":") + 2), Chr(7), "")
ma = doc.Tables(1).Cell(3, 1).Range.text
ketqua(sodong_ketqua + r, 11) = Replace(Mid(ma, InStr(1, ma, ":") + 2), Chr(7), "")
Next r
End With
sodong_ketqua = sodong_ketqua + sodong
doc.Close False
Next k
wordApp.Quit
Set doc = Nothing
Set wordApp = Nothing
dulieuPXK = ketqua
End Function
Sub lay_dulieu()
Dim sodong_ketqua As Long, docFilename, ketqua, ngaythang()
docFilename = Application.GetOpenFilename("Word Files (*.doc;*.docx), *.doc;*.docx", MultiSelect:=True)
If Not IsArray(docFilename) Then Exit Sub
ketqua = dulieuPXK(docFilename, sodong_ketqua, ngaythang)
If sodong_ketqua > 0 Then
With ThisWorkbook.Worksheets("TEMP")
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(sodong_ketqua, UBound(ketqua, 2)).Value = ketqua
.Range("Q1:R1").Resize(UBound(ngaythang, 1)).Value = ngaythang ' cot Q:R
End With
End If
End Sub
