|
|
Sub word到excel()
Application.ScreenUpdating = False
Dim i As Long
Dim arr()
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0) '选择文件夹对话框
If obmapp Is Nothing Then MsgBox "您没有选择文件夹！": End '如果选择了文件夹
fp = obmapp.Self.Path '把选择的文件夹的路劲赋值给变量fp
f = Dir(fp & "\*.doc*")
ReDim arr(1 To 100000, 1 To 18)
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application") '新建Word对象
WordApp.Visible = True
t = Timer
Do While f <> ""
Set WordD = WordApp.Documents.Open(fp & "\" & f)
If WordD.tables.Count > 0 Then
With WordD.tables(1)
r = .Rows.Count
n = n + 1
arr(n, 1) = n
y = 1
For i = 1 To 2
For j = 2 To 4 Step 2
y = y + 1
arr(n, y) = Replace(.Cell(i, j).Range.Text, Chr(13) & Chr(7), "")
Next j
Next i
For i = 3 To 6
For j = 3 To 5 Step 2
y = y + 1
arr(n, y) = Replace(.Cell(i, j).Range.Text, Chr(13) & Chr(7), "")
Next j
Next i
For i = 7 To 8
For j = 2 To 4 Step 2
y = y + 1
If y = 17 Then
y = 18
Else
y = y
End If
arr(n, y) = Replace(.Cell(i, j).Range.Text, Chr(13) & Chr(7), "")
Next j
Next i
End With
End If
WordD.Close False
f = Dir
Loop
WordApp.Quit
Set WordApp = Nothing
Set WordD = Nothing
With Sheets("Sheet1")
.[a1].CurrentRegion.Offset(3).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(3) = Empty
.[a4].Resize(n, UBound(arr, 2)) = arr
.[a4].Resize(n, UBound(arr, 2)).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "获取到" & n & "行数据,耗时：" & Format(Timer - t, "0.00") & "秒!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-15 13:23
楼主