同文件夹提取每个Word内同一位置的内容到Excel表里(修改为Excel运行代码）

jdsl88

同一文件夹中有很多类似Word文件（测试里只有两个，实际上有几百个），每个Word文件的每页都有格式相同的2个表格，其中一个表格（只是1列2行的小表）位于每页右上角，如何通过Excel表运行VBA代码提取相同文件夹内每个Word文件每页右上角表格第1行内容到Sheet1表中。要求：在sheet1表A列填入每个Word文件名称（每个Word有多少页对应填入多少行文件名称），B列填入对应每个Word文件按序提取每页右上角表格第1行的内容。

请师傅们结合附件帮忙实现一下，实现后结果如图:

shiruiqiang

wps？没宏模块？

liulang0808

楼主在论坛里先搜下雷同案例，应该有的。
另外wps是否可以运行，不确定，还得楼主在wps环境下测试看看

wanghan519

wps里写起来有点怪，要不试试批处理

1. #&cls&powershell "type '%~0'|out-string|iex"&pause&exit
   
2. $wd = New-Object -ComObject kwps.application
   
3. $xl = New-Object -ComObject ket.application
   
4. $b = $xl.Workbooks.Open((Resolve-Path 整理后目录.xls).Path)
   
5. $s = $b.Activesheet
   
6. $n = 1
   
7. dir *.docx | %{
   
8.     $d = $wd.Documents.Open($_.FullName)
   
9.     $s.Range("A"+$n).Value2 = $d.Tables(1).Cell(1, 1).Range.Text -replace "`r.*$"
   
10.     $d.Close()
    
11.     $n += 1
    
12. }
    
13. $wd.Quit()
    
14. $b.Save()
    
15. $b.Close()
    
16. $xl.Quit()
    
17. [System.Runtime.InteropServices.Marshal]::ReleaseComObject($wd) | Out-Null
    
18. [System.Runtime.InteropServices.Marshal]::ReleaseComObject($xl) | Out-Null

复制代码

过客fppt

可以直接在WPS的Word中提取生成表格，再复制到execl中更方便（用WPS的execl调用Wordapplication会有莫名其妙的错误，没有office那么稳定）

jdsl88

wanghan519 发表于 2024-4-21 11:43
wps里写起来有点怪，要不试试批处理

感谢师傅的帮助，批处理结果只提取了一个Word文件里的前两内容，其他没提取到，不知是不是我操作有问题

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar(), i&, r&, wdApp As Object, wdTable As Object
    Dim strFileName$, strPath$, strName$
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    ReDim ar(1 To 10 ^ 3, 1)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.doc*")
    Do Until strFileName = ""
        strName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        With wdApp.documents.Open(strPath & strFileName)
            For Each wdTable In .Tables
                If InStr(wdTable.Range.Cells(1).Range.Text, "档案编号") Then
                    r = r + 1
                    ar(r, 0) = strName
                    ar(r, 1) = Left(wdTable.Range.Cells(1).Range.Text, Len(wdTable.Range.Cells(1).Range.Text) - 2)
                End If
            Next
            .Close False
        End With
        strFileName = Dir
    Loop
   
    [A1].CurrentRegion.Clear
    If r Then [A1].Resize(r, 2) = ar
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

office 环境，不知道行不行

jdsl88

gwjkkkkk 发表于 2024-4-21 20:33
office 环境，不知道行不行

首先感谢师傅热心指点，运行代码向您反馈:执行代码后只提取了最后一个Word所有页内容，其他的只是把Word文件名称提出出来了，可见截图。

gwjkkkkk

你再发几个文件上来，我按你提供的文件来写的，不知道其他文件的结构是否相同。。。