从多个Word文档中提取数据和解决运行时错误代码“4605”所需的Excel宏修改

link之家

链接快照平台

输入网页链接，自动生成快照
标签化管理网页链接

相关文章推荐

不羁的课本 · 在 uni-app ...· 7 月前 ·

玉树临风的水桶 · 中国代表团出席联合国麻醉药品委员会第54届会 ...· 1 年前 ·

有腹肌的油条 · C++ ...· 1 年前 ·

乖乖的电池 · Java中的回调机制及其优势_java回调机 ...· 1 年前 ·

不羁的番茄 · 国内大市场优势与企业自主创新· 1 年前 ·

腾讯云

开发者社区

文档意见反馈控制台

首页 TVP

文章/答案/技术大牛

发布

Sub ImportFromWord()
On Error Resume Next
  'Activate Word Object Library
  Dim WordDoc As Word.Document
  Set WordApp = CreateObject("word.application") ' Open Word session
  WordApp.Visible = False 'keep word invisible
  Set WordDoc = WordApp.Documents.Open("C:\Users\brendan.ramsey\OneDrive - Ofcom\Objectives\Brendan's Objectives 2022-23\Licence calls\test 2.docx") ' open Word file
  'copy third row of first Word table
  WordDoc.Tables(1).Cell(Row:=1, Column:=3).Range.Copy
  'paste in Excel
  Range("A3").PasteSpecial xlPasteValues
  WordDoc.Tables(4).Cell(Row:=3, Column:=6).Range.Copy
  Range("B3").PasteSpecial xlPasteValues
  WordDoc.Tables(4).Cell(Row:=3, Column:=3).Range.Copy
  Range("C3").PasteSpecial xlPasteValues
  WordDoc.Tables(5).Cell(Row:=2, Column:=5).Range.Copy
  Range("D3").PasteSpecial xlPasteValues
  WordDoc.Tables(5).Cell(Row:=2, Column:=7).Range.Copy
  Range("E3").PasteSpecial xlPasteValues
  WordDoc.Tables(5).Cell(Row:=2, Column:=2).Range.Copy
  Range("F3").PasteSpecial xlPasteValues
  WordDoc.Close 'close Word doc
  WordApp.Quit ' close Word
End Sub

Sub ImportFromWord()
    Const FLDR_PATH As String = "C:\Temp\Docs\"
    Dim WordDoc As Word.Document, WordApp As Word.Application
    Dim rw As Range, f
    Set rw = ActiveSheet.Rows(3) 'or some other sheet
    f = Dir(FLDR_PATH & "*.doc*") 'check for document
    Do While Len(f) > 0
        If WordApp Is Nothing Then 'open word if not already open
            Set WordApp = CreateObject("word.application")
            WordApp.Visible = False
        End If
        With WordApp.Documents.Open(FLDR_PATH & f, ReadOnly:=True) ' open Word file
            WordCellToExcel .Tables(1).Cell(Row:=1, Column:=3), rw.Cells(1)
            WordCellToExcel .Tables(4).Cell(Row:=3, Column:=6), rw.Cells(2)
            WordCellToExcel .Tables(4).Cell(Row:=3, Column:=3), rw.Cells(3)
            'etc etc
            .Close savechanges:=False
        End With
        Set rw = rw.Offset(1) 'next row down
        f = Dir()             'next file, if any
    If Not WordApp Is Nothing Then WordApp.Quit ' close Word if it was opened
End Sub

从多个Word文档中提取数据和解决运行时错误代码“4605”所需的Excel宏修改

2 个回答