|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub GetStrByWord()
- Dim SH As Worksheet, lngRowIndex As Long
- Dim strFileName As String, strPath As String, strTemp As String
- Dim strID As String, strName As String, strMemo As String
- Dim objDoc As Object, objTable As Object
- Dim arrResult(1 To 1, 1 To 10) As Variant
-
- Set SH = Sheets("Sheet1")
- lngRowIndex = SH.Range("A" & Rows.Count).End(xlUp).Row
- If lngRowIndex < 2 Then lngRowIndex = 2
- SH.Range("A2:J" & lngRowIndex).ClearContents
- lngRowIndex = 2
-
- Application.ScreenUpdating = False
- Application.Cursor = xlWait
-
- strPath = ThisWorkbook.Path
- strFileName = Dir(strPath & "" & "*.doc*")
-
- Do Until strFileName = ""
- strTemp = Split(strFileName, ".")(0)
- strID = Mid(strTemp, 1, 4)
-
- strTemp = Mid(strTemp, 5)
- If InStr(strTemp, "(") > 0 Then
- strName = Split(strTemp, "(")(0)
- strMemo = Split(strTemp, "(")(1)
- strMemo = Mid(strMemo, 1, Len(strMemo) - 1)
- Else
- strName = strTemp
- strMemo = ""
- End If
-
- Set objDoc = GetObject(strPath & "" & strFileName)
- If objDoc.tables.Count > 0 Then
- Set objTable = objDoc.tables(1)
- arrResult(1, 1) = strID
- arrResult(1, 2) = strName
- arrResult(1, 3) = strMemo
- arrResult(1, 4) = Replace(objTable.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 5) = Replace(objTable.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 6) = Replace(objTable.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 7) = Replace(objTable.Cell(4, 2).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 8) = Replace(objTable.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 9) = Replace(objTable.Cell(6, 2).Range.Text, Chr(13) & Chr(7), "")
- arrResult(1, 10) = Replace(objTable.Cell(7, 4).Range.Text, Chr(13) & Chr(7), "")
- SH.Range("A" & lngRowIndex).Resize(1, 10) = arrResult
- lngRowIndex = lngRowIndex + 1
- End If
- objDoc.Close False
- strFileName = Dir()
- Loop
- Set objDoc = Nothing
-
- Application.ScreenUpdating = True
- Application.Cursor = xlDefault
- MsgBox "导入成功!共导入信息【" & lngRowIndex - 2 & "】条"
- End Sub
复制代码 |
|