从Word复制到Excel粘贴表

本文介绍了从Word复制到Excel粘贴表的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述

我有一个word文档，该文档会定期更新。我可以进入该Word文档，选择整个表的内容并复制，然后进入Excel电子表格并粘贴。它搞砸了；但是，我将其修复如下：

I have a word document which is updated periodically. I can go into that Word document, select the contents of an entire table and copy, then go into an Excel spreadsheet and paste it. It's screwed up; however, I fix it as follows:

sht.Cells.UnMerge sht.Cells.ColumnWidth = 14 sht.Cells.RowHeight = 14 sht.Cells.Font.Size = 10

无论表是否具有合并字段，此手动复制粘贴均有效。 然后我可以开始手动操作它：解析，检查，计算等。

This manual copy-paste works regardless of whether the table is has merged fields. Then I can start to manipulate it manually: parsing, checking, computations, etc.

我可以一次做一张桌子，但是这很繁琐，而且当然容易出错。

I can do this one table at a time, but it's tedious and of course error prone.

我想使它自动化。我找到了一些代码：

I want to automate this. I found some code:

Sub read_word_document() Dim sht As Worksheet Dim WordDoc As Word.Document Dim WordApp As Word.Application Set WordApp = CreateObject("Word.Application") WordApp.Visible = False On Error GoTo ErrHandler Set WordDoc = WordApp.Documents.Open("Z:\mydir\myfile1.DOC", ReadOnly:=True) j = 0 For i = 1 To WordDoc.Tables.Count DoEvents Dim s As String s = WordDoc.Tables(i).Cell(1, 1).Range.Text Debug.Print i, s WordDoc.Tables(i). Set sht = Sheets("temp") 'sht.Cells.Clear sht.Cells(1, 1).Select sht.PasteSpecial (xlPasteAll) End If Next i WordDoc.Close WordApp.Quit GoTo done ErrClose: On Error Resume Next ErrHandler: Debug.Print Err.Description On Error GoTo 0 done: End Sub

当然，这只会覆盖一次又一次地在同一张纸上-没关系。这只是一个测试。问题是这将适用于那些没有合并单元格的表。但是，如果表具有合并的单元格，它将失败。我无法控制获得的文件。它包含近一百张桌子。

Of course this would just overwrite the same sheet again and again - and that's okay. This is just a test. The problem is this will work for those tables that do not have merged cells. However, it fails if the table has merged cells. I have no control over the file I get. It contains almost a hundred tables. Is there a way to do the copy paste the EXACT WAY that I do when I perform the operation manually?

推荐答案

像这样的事情，有没有一种方法可以像我手动执行操作时那样粘贴复制？ ：

Something like this:

Sub read_word_document() Const DOC_PATH As String = "Z:\mydir\myfile1.DOC" Dim sht As Worksheet Dim WordDoc As Word.Document Dim WordApp As Word.Application Dim i As Long, r As Long, c As Long Dim rng As Range, t As Word.Table Set WordApp = CreateObject("Word.Application") WordApp.Visible = False Set WordDoc = WordApp.Documents.Open(DOC_PATH, ReadOnly:=True) Set sht = Sheets("Temp") Set rng = sht.Range("A1") sht.Activate For Each t In WordDoc.Tables t.Range.Copy rng.Select rng.Parent.PasteSpecial Format:="Text", Link:=False, _ DisplayAsIcon:=False With rng.Resize(t.Rows.Count, t.Columns.Count) .Cells.UnMerge .Cells.ColumnWidth = 14 .Cells.RowHeight = 14 .Cells.Font.Size = 10 End With Set rng = rng.Offset(t.Rows.Count + 2, 0) Next t WordDoc.Close WordApp.Quit End Sub