怎样把word里面的内容提取到Excel表格中

小花鹿

liucong835016 发表于 2019-4-15 09:11
就是例如我的文档是文档1-1000，提取到Excel中不是按照1-1000的顺序排列的，Excel里面会乱

dir不是按1到1000的顺序提取文件的，除非是0001，0002这样的文件名，只能是事后再想办法排序了

liucong835016

QQ能告知一下吗？

liucong835016

问题见图

爱疯

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)

2019-4-15 10:29 上传

点击文件名下载附件

81160330

测试看看那行不行

liucong835016

第二次这个代码会出现调试错误

liucong835016

爱疯 发表于 2019-4-15 10:29
Option Explicit

Dim A(1 To 10 ^ 4, 1 To 3), i

你这个运行的时候会出现错误

爱疯

liucong835016 发表于 2019-4-15 17:55
你这个运行的时候会出现错误

建议上传出错的附件，否则不好判断

81160330

我再来试试看

81160330

我再来试试看