把不同的word表格内容汇总到excel中

xiangheping

求大神帮忙，把不同word表中第第三行的内容汇总到excel中E列中，谢谢

3190496160

Sub 批量提取()
Application.ScreenUpdating = False
Dim strFolder As String '文件夹路径
Dim strFile As String '文件名
strFolder = ActiveWorkbook.Path '获取当前打开的Excel工作表所在的文件夹路径
strFile = Dir(strFolder & "\*.doc*") '获取当前文件夹下的所有*.doc*文件
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False '设置Word应用程序不可见以避免干扰
Dim arr()
ReDim arr(1 To 100000, 1 To 1)
Do While strFile <> ""
    Set wdDoc = wdApp.Documents.Open(strFolder & "\" & strFile)
    n = n + 1
    With wdDoc.tables(1)
        arr(n, 1) = Replace(.Cell(3, 1).Range.Text, Chr(13) & Chr(7), "")
    End With
    wdDoc.Close False
strFile = Dir
Loop
With Sheet1
     r = .Cells(Rows.Count, 5).End(xlUp).Row
     If r >= 6 Then .Range("e6:e" & r) = Empty
    .[e6].Resize(n, UBound(arr, 2)) = arr
End With
Set wdDoc = Nothing
wdApp.Quit
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

汇总.rar (38.68 KB, 下载次数: 15)

2023-4-18 11:40 上传

点击文件名下载附件

xiangheping

3190496160 发表于 2023-4-18 11:40

谢谢，好像word文档多于两个就报错

xiangheping

3190496160 发表于 2023-4-18 11:40

文档多于2个就报错

3190496160

xiangheping 发表于 2023-4-18 12:11
文档多于2个就报错

这个跟多少个word文档没有任何关系的，检查你的word文档，有没有表格

xiangheping

3190496160 发表于 2023-4-18 14:29
这个跟多少个word文档没有任何关系的，检查你的word文档，有没有表格

一样的内容，我放三个进去就不正常了，删除一个又可以了

xiangheping

3190496160 发表于 2023-4-18 14:29
这个跟多少个word文档没有任何关系的，检查你的word文档，有没有表格

Sub lqxs_提取数据()
Dim n%, doc, f, wd, arr(1 To 1000, 1 To 4), nm$, m$

On Error Resume Next

f = Dir(ThisWorkbook.Path & "\*.docx")
m = 0
Do While f <> ""
nm = Split(f, "公司")(0) & "公司"

Set wd = GetObject(ThisWorkbook.Path & "\" & f)
With wd

m = m + 1

Set tb = .Tables(1)
With tb
For i = 2 To tb.Rows.Count
n = n + 1
arr(n, 1) = n '编号
arr(n, 2) = nm '公司
arr(n, 3) = qczbf(.cell(i, 2).Range) '资源名称
arr(n, 4) = qczbf(.cell(i, 3).Range) ' 资源描述
Next
End With

wd.Close False
End With
f = Dir()
Loop

Set wd = Nothing
If m <> 0 Then _
Sheet1.Activate
[a3].Resize(5000, 4).ClearContents
[a3].Resize(5000, 4).Borders.LineStyle = xlNone
[a3].Resize(n, 4) = arr
[a3].Resize(n, 4).Borders.LineStyle = 1
MsgBox "完成!"
End Sub

Function qczbf(a)
qczbf = Left(a, Len(a) - 2)
End Function
大神，能按这个帮我修改一下吗，我在论坛找的，自己修改了下，实在不会

3190496160

xiangheping 发表于 2023-4-18 15:54
Sub lqxs_提取数据()
Dim n%, doc, f, wd, arr(1 To 1000, 1 To 4), nm$, m$

已经给你代码了，再上传的文档中是一切正常的，而且，已经跟你说过了，跟word文档的个数没有任何关系，不从根本上找原因，而是舍本求末