|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 mzbao 于 2019-3-21 10:02 编辑
Sub ReadFromWord()
Dim oDoc As Object
Dim myPath$, MyName$, k%, JDDate$, arr(), i%, j%
Range("A2:F2000").ClearContents
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.doc*")
k = 1
Do While MyName <> ""
If InStr(1, MyName, "农户信用(经济)档案") Then
Set oDoc = GetObject(myPath & MyName)
k = k + 1
Cells(k, 1) = k - 1
Cells(k, 2) = oDoc.Tables(1).Cell(3, 2).Range.Text
Cells(k, 3) = oDoc.Tables(1).Cell(3, 6).Range.Text
Cells(k, 4) = oDoc.Tables(1).Cell(6, 2).Range.Text
JDDate = oDoc.Paragraphs(3).Range.Text
JDDate = Split(Split(JDDate, " ")(0), ":")(1)
Cells(k, 5) = JDDate
Cells(k, 6) = oDoc.Tables(1).Cell(7, 2).Range.Text
oDoc.Close True
End If
MyName = Dir
Loop
'删除黑点
arr = Range("A2:F" & k).Value
For i = 1 To UBound(arr)
For j = 2 To 6
If j <> 5 Then
arr(i, j) = Left(arr(i, j), Len(arr(i, j)) - 1)
End If
Next j
Next
Range("A2:F" & k) = arr
End Sub
|
评分
-
1
查看全部评分
-
|