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

相关文章推荐

千年单身的生姜 · Wizard ...· 5 月前 ·

讲道义的鸡蛋面 · 30元看片，300元定制，虐猫产业链到底有多 ...· 1 年前 ·

爽快的花卷 · 她被称为“国民媳妇”，误将安全裤送给导演，被 ...· 1 年前 ·

乐观的签字笔 · 深圳内推 | ...· 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 个回答