建议将所有文件移到一个文件夹中。
注意,所有文档的表格应该一致!
此代码在EXCEL工作薄中。
以下代码供参考:
'* +++++++++++++++++++++++++++++
'* Created By I Love You_Word!@ExcelHome 2005-11-9 10:48:50
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'№ 00043^The Code CopyIn EXCEL'
'* -----------------------------
Option Explicit
Sub GetDocText()
'运行此宏前请在VBE 工具/引用中勾选对于MICROSOFT WORD 10.0 OBJICT LIBRARY的引用
Dim wdApp As Word.Application, wdDoc As Word.Document, myDialog As FileDialog
Dim wdaCell As Word.Cell, N As Integer, aDoc As Variant, TF As Boolean
Dim wdRange As Word.Range
Dim myRange As Range, EndAddress As Long, myArray(11) As String, m As Byte
Set myDialog = Application.FileDialog(msoFileDialogFilePicker) '定义一个打开文件夹对象
With myDialog
.AllowMultiSelect = True '允许多选
.Filters.Clear '清除项目
.Filters.Add "All Word Document", "*.doc" '增加*.DOC项目
If .Show <> -1 Then Exit Sub '如果非执行了确定按钮则退出程序
Application.ScreenUpdating = False '关闭屏幕更新
On Error Resume Next '忽略错误
Set wdApp = GetObject(, "Word.Application") '获得对WORD程序对象的引用
If Err.Number <> 0 Then '如果引用不存在,发生错误
Err.Clear '清除错误
TF = True '设置TF值
Set wdApp = CreateObject("Word.Application") '创建一个WORD.APPLICATION对象
End If
For Each aDoc In .SelectedItems '在所选文件项目中循环
With Sheets("Sheet1")
EndAddress = .[A65536].End(xlUp).Offset(1, 0).Row '取得A列最后一行的下一行行号(最上空白行)
Set myRange = .Range("A" & EndAddress & ":L" & EndAddress) '定义一个RANGE对象
End With
N = 0: m = 0 '初始化变量
Set wdDoc = wdApp.Documents.Open(FileName:=aDoc, Visible:=False) '定义一个DOCUMENT对象
With wdDoc
For Each wdaCell In .Tables(1).Range.Cells '在文档的表格1的单元格中循环
N = N + 1
If N Mod 2 = 0 Then '如果是双数
'取得单元格文本内容
Set wdRange = .Range(wdaCell.Range.Start, wdaCell.Range.End - 1)
myArray(m) = wdRange '向数组赋值
m = m + 1 '累加
End If
Next
.Close False '关闭并不保存文档
End With
myRange = myArray '向单元格区域赋值
Erase myArray '清空数组
Next
End With
If TF = True Then wdApp.Quit '如果原来没有WORD程序,则关闭WORD程序
Set wdApp = Nothing '释放对象变量
Application.ScreenUpdating = True '恢复屏幕更新
MsgBox "程序运行结束,请查对!", vbInformation, "Excelhome" '提示程序运行结束
End Sub
'----------------------
FZBg6sFi.zip
(12.08 KB, 下载次数: 106)
[此贴子已经被作者于2005-11-9 10:57:10编辑过] |