|
Option Explicit
Dim A(1 To 10 ^ 4, 1 To 3), i
'入口
Sub wd2sht()
Dim p, f
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'1)清除
Sheets(1).Select
[a4:k65536] = ""
'2)收集
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.doc*")
Do While f <> ""
Call Wd2Arr(p, f)
f = Dir()
Loop
'3)输出
If i Then
Range("f3:g" & i + 3).UnMerge
[f4].Resize(i, UBound(A, 2)) = A
Range("a3").CurrentRegion.Sort key1:=[g1], order1:=xlAscending, Header:=xlYes
Range("f3:g" & i + 3).Merge Across:=True
End If
End Sub
'文档到数组
Sub Wd2Arr(p, f)
Dim wd
Set wd = GetObject(p & f)
i = i + 1
A(i, 1) = zh(wd.tables(1).Cell(3, 1).Range.Text)
A(i, 2) = 0 + Left(f, InStr(f, ".") - 1)
A(i, 3) = zh(wd.tables(1).Cell(6, 3).Range.Text)
wd.Close 0
End Sub
'去除特殊字符
Function zh(x)
zh = Left(x, Len(x) - 2)
End Function
2.rar
(20.42 KB, 下载次数: 32)
|
|