当前位置：首页 → 问答吧 → 感谢zhaogang1960与kevinchengcw两位老师的热情帮助，复制WORD所有内容至当前表中

感谢zhaogang1960与kevinchengcw两位老师的热情帮助，复制WORD所有内容至当前表中

时间：2011-08-07

来源：互联网

大家好！请问如何修改为直接复制Word所有内容到当前工作表中

[ 本帖最后由 zslyyy 于 2011-8-7 22:37 编辑 ]

附件

Word复制到Excel.rar(66.88 KB)

2011-8-7 20:58, 下载次数: 24

作者: zslyyy 发布时间: 2011-08-07

短信收到，请测试
Sub Macro1()
Dim f As String, t As Object, arr(1 To 60000, 1 To 10), i&, j&, m&
Application.ScreenUpdating = False
With CreateObject("WORD.APPLICATION")
      .Visible = True
      MyPath = ThisWorkbook.Path & "\"
      f = Dir(MyPath & "*.doc")
      Do While f <> ""
         .Documents.Open MyPath & f
         Set t = .ActiveDocument.Tables(1)
         For i = 1 To t.Rows.Count
            m = m + 1
            For j = 1 To t.Columns.Count
                  arr(m, j) = Replace(t.Cell(i, j).Range.Text, Chr(7), "")
            Next
         Next
         .ActiveDocument.Close
         f = Dir
      Loop
      .Quit
End With
ActiveSheet.UsedRange.ClearContents
[a1].Resize(m, 10) = arr
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 zhaogang1960 于 2011-8-7 21:34 编辑 ]

作者: zhaogang1960 发布时间: 2011-08-07

多谢赵老师您的指导

作者: zslyyy 发布时间: 2011-08-07

复制内容到剪贴板

代码:

Sub test()
Dim WordApp As Object, WD As Object, FN$, Rng As Range
FN = Dir(ThisWorkbook.Path & "\*.doc")
Set WordApp = CreateObject("word.application")
WordApp.Visible = False
Do While FN <> ""
Set WD = WordApp.Documents.Open(ThisWorkbook.Path & "\" & FN)
If [a1] = "" Then
      Set Rng = [a1]
Else
      Set Rng = Cells(Rows.Count, 1).End(3).Offset(1)
End If
With WD
      If .Tables.Count > 0 Then
         .Tables(1).Range.Copy
         ActiveSheet.Paste Rng
      End If
      .Close False
End With
FN = Dir
Loop
WordApp.Quit
Set WordApp = Nothing
End Sub

这个试下

[ 本帖最后由 kevinchengcw 于 2011-8-7 21:49 编辑 ]

作者: kevinchengcw 发布时间: 2011-08-07

你好！请问多加一个word表格为何不可以呢？但会再复制一遍之前的数据
名字不同的时候会出现这情况，也就是得顺着，如1、2、3、。。。，但1、2、3、数据1、。。。这样就不行了

[ 本帖最后由 zslyyy 于 2011-8-7 21:57 编辑 ]

作者: zslyyy 发布时间: 2011-08-07

引用:

原帖由 kevinchengcw 于 2011-8-7 21:47 发表
Sub test()
Dim WordApp As Object, WD As Object, FN$, Rng As Range
FN = Dir(ThisWorkbook.Path & "\*.doc")
Set WordApp = CreateObject("word.application")
WordApp.Visible = False
Do While FN ""
...

这个用复制法效果不错，测试了一下，速度比2楼快

作者: zhaogang1960 发布时间: 2011-08-07

没懂你说的意思，我的代码只计划了一次性使用，所以没有清空原有数据

作者: kevinchengcw 发布时间: 2011-08-07

谢谢！正是我想要的，再次感谢！

作者: zslyyy 发布时间: 2011-08-07

是快很多，不过还是感谢你对我们这些菜鸟的帮助，谢谢

作者: zslyyy 发布时间: 2011-08-07

如果每个word文档有多个表格都需要复制：
Sub Macro2() '每个word有多个表格
Dim f As String, t As Object, arr(1 To 60000, 1 To 10), i&, j&, m&
Application.ScreenUpdating = False
With CreateObject("WORD.APPLICATION")
      .Visible = True
      MyPath = ThisWorkbook.Path & "\"
      f = Dir(MyPath & "*.doc")
      Do While f <> ""
         .Documents.Open MyPath & f
         For Each t In .ActiveDocument.Tables
'          Set t = .ActiveDocument.Tables(1)
            For i = 1 To t.Rows.Count
                  m = m + 1
                  For j = 1 To t.Columns.Count
                     arr(m, j) = Replace(t.Cell(i, j).Range.Text, Chr(7), "")
                  Next
            Next
         Next
         .ActiveDocument.Close
         f = Dir
      Loop
      .Quit
End With
ActiveSheet.UsedRange.ClearContents
[a1].Resize(m, 10) = arr
Application.ScreenUpdating = True
End Sub

4楼代码也可以这样修改

作者: zhaogang1960 发布时间: 2011-08-07

谢谢！您太历害了，我得好好学习啊