从同一文件夹下获取多张相同word表格中指定数据到Excel

bjjczxx

求助：从同一文件夹下获取多张相同word表格中指定数据到Excel

jiangxiaoyun

这个还是挺好搞的

山菊花

稍作修改。

bjjczxx

山菊花 发表于 2023-11-25 13:55
稍作修改。

运行时找不到工程或库

山菊花

引用：Microsoft Word 16.0 Object Library
或者：
  Dim myhdoc As  Word.Document
改为：
  Dim myhdoc As Object

3190496160

Sub test()
Application.ScreenUpdating = False
  Dim arr(1 To 1000, 1 To 6)
  Dim myPath$, myname$
  Dim WordApp As Object
  Set WordApp = CreateObject("word.application")
  WordApp.Visible = True
  myPath = ThisWorkbook.Path & "\"
  myname = Dir(myPath & "*.docx")
  m = 0
  Do While myname <> ""
    Set mydoc = WordApp.Documents.Open(myPath & myname)
    m = m + 1
    With mydoc
      With .tables(1)
        arr(m, 1) = Replace(.Cell(1, 2).Range.Text, Chr(7), "")
        arr(m, 2) = Replace(.Cell(3, 2).Range.Text, Chr(7), "")
        arr(m, 3) = Replace(.Cell(3, 4).Range.Text, Chr(7), "")
        arr(m, 4) = Replace(.Cell(7, 2).Range.Text, Chr(7), "")
        arr(m, 5) = Replace(.Cell(8, 2).Range.Text, Chr(7), "")
      End With
      .Close False
    End With
    myname = Dir()
  Loop
  WordApp.Quit
  With Worksheets("sheet1")
    .[a1].CurrentRegion.Offset(1) = Empty
    .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
  End With
Application.ScreenUpdating = True
MsgBox "完成"
End Sub

3190496160

从word提取指定资料到Excel.rar (42.24 KB, 下载次数: 11)

2023-11-25 21:04 上传

点击文件名下载附件